I have been searching on the internet where to find the most efficient and simple way of the following:
I have a spreadsheet that contains 3 sheets:
information
training
Leavers
Within the information sheet, column B contains a validation text that is conditionally formatted. There are two validation options:
Active
Leaver
I want that once the cell value is changed from 'active' to 'Leaver' that the whole row would be removed from the sheet and moved to 'Leaver's sheet.
I have used the code below, it works, however if there is no Leavers it will transfer the first row of 'active'. Can anyone tell me what is the problem?
Sub AlexR688(x)
'For http://www.mrexcel.com/forum/excel-q...ific-text.html
'Using autofilter to Copy rows that contain centain text to a sheet called Errors
Dim LR As Long
Range("B2").EntireRow.Insert Shift:=xlDown
LR = Sheets("Personal Information").Cells(Rows.Count, "B").End(xlUp).Row
LR1 = Sheets("Leavers").Cells(Rows.Count, "B").End(xlUp).Row + 1
With Sheets("Personal Informaiton").Range("B2:C" & LR)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="Leaver", _
Operator:=xlOr, Criteria2:=":Leaver"
.SpecialCells(xlCellTypeVisible).EntireRow.Copy Destination:=Sheets("Leavers").Range("A" & LR1)
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
End Sub
Secondly, I want to make the same in the 'Training' sheet. But in there, column B, contains the same 'Active', 'Leavers' which is referenced from personal information. So, once the Personal information sheet column B is changed from 'active' to 'leaver', training sheet will change as well, but i want the row in the training sheet would be deleted.
Thirdly, if I accidentally moved row from Personal information sheet to Leavers sheet, is it possible that by selecting back to 'active' cell value the row would move back to where it was?
Thank you very much. Hope it is clear enough.
this is the easiest way
Private Sub imperecheaza_Click()
Dim ws As Worksheet
Dim Rand As Long
Set ws = Worksheets("BD_IR")
Rand = 3
Do While ws.Cells(Rand, 4).Value <> "" And Rand < 65000
If ws.Cells(Rand, 4).Value = gksluri.Value * 1 And ws.Cells(Rand, 5).Value = gksluri.List(gksluri.ListIndex, 1) * 1 Then
ws.Rows(Rand) = "" '(here you will delete entire Row)
gksluri.RemoveItem gksluri.ListIndex
Exit Do
End If
Rand = Rand + 1
Loop
End Sub
Related
Background: This is my first time dealing with macros. I will have two worksheets that I’ll be using. The first sheet, ‘Source’ will have data available. The second sheet, ‘Final’ will be blank and is going to be where the macro will be pasting the data I’d like it to collect from the ‘Source’ sheet.
* I want the macro to find the specified header in the ‘Source’ sheet, copy that cell containing the header all the way down to the last row of existing data (instead of the entire column), and paste it onto the ‘Final’ sheet in a specified column (A, B, C, etc.). *
The reason why I have to specify which headers to find is because the headers in the ‘Source’ sheet won’t always be in the same position, but the ‘Final’ sheet’s headers will always be in the same position – so I CAN’T just record macros copying column A in ‘Source’ sheet and pasting in column A in ‘Final’ sheet. Also, one day the ‘Source’ sheet may have 170 rows of data, and another day it may have 180 rows.
Although, it would probably be best to copy the entire column since one of the columns will have a few empty cells rather than to the last row of existing data. I’m assuming it would stop copying when it reaches the first empty cell in the column chosen which would leave out the remaining data after that empty cell in the column – correct me if I’m wrong. If copying the entire column is the best way, then, please provide that as part of the possible solution. I’ve attached an example of the before & after result I would like accomplished:
Example of Result
Find Header=X, copy entire column -> Paste into A1 in ‘Final’ sheet
Find Header=Y, copy entire column -> Paste into B1 in ‘Final’ sheet
Etc..
I’m sorry if my wording isn’t accurate – I tried to explain the best I could. It’d be awesome if someone could help me out on this! Thanks!
u can try with this. i think its clear and step-by-step. it can be very optimized, but to start with vba i think its better this way.
the name of the column must be the same in both sheets.
Sub teste()
Dim val
searchText = "TEXT TO SEARCH"
Sheets("sheet1").Select ' origin sheet
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
x = Selection.Columns.Count ' get number of columns
For i = 1 To x 'iterate trough origin columns
val = Cells(1, i).Value
If val = searchText Then
Cells(1, i).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("sheet2").Select ' destination sheet
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
y = Selection.Columns.Count ' get number of columns
For j = 1 To y 'iterate trough destination columns
If Cells(1, j).Value = searchText Then
Cells(1, j).Select
ActiveSheet.Paste
Exit Sub
End If
Next j
End If
Next i
End Sub
good luck
I modified an answer I gave to another user with similar problem for your case,
I use dictionary function in most of my data sheets so that I can shift columns around without breaking the code, the below code you can shift your columns around and it will still work
the only main restriction is
1. your header names must be unique
2. your header name of interest must be exactly the same.
i.e. your source header of interest is PETER then your Data table should have a header with PETER and it must be unique.
Sub RetrieveData()
Dim wb As Workbook
Dim ws_A As Worksheet
Dim ws_B As Worksheet
Dim HeaderRow_A As Long
Dim HeaderLastColumn_A As Long
Dim TableColStart_A As Long
Dim NameList_A As Object
Dim SourceDataStart As Long
Dim SourceLastRow As Long
Dim Source As Variant
Dim i As Long
Dim ws_B_lastCol As Long
Dim NextEntryline As Long
Dim SourceCol_A As Long
Set wb = ActiveWorkbook
Set ws_A = wb.Worksheets("Sheet A")
Set ws_B = wb.Worksheets("Sheet B")
Set NameList_A = CreateObject("Scripting.Dictionary")
With ws_A
SourceDataStart = 2
HeaderRow_A = 1 'set the header row in sheet A
TableColStart_A = 1 'Set start col in sheet A
HeaderLastColumn_A = .Cells(HeaderRow_A, Columns.Count).End(xlToLeft).Column 'Get number of NAMEs you have
For i = TableColStart_A To HeaderLastColumn_A
If Not NameList_A.Exists(UCase(.Cells(HeaderRow_A, i).Value)) Then 'check if the name exists in the dictionary
NameList_A.Add UCase(.Cells(HeaderRow_A, i).Value), i 'if does not exist record name as KEY and Column number as value in dictionary
End If
Next i
End With
With ws_B 'worksheet you want to paste data into
ws_B_lastCol = .Cells(HeaderRow_A, Columns.Count).End(xlToLeft).Column ' Get number of DATA you have in sheet B
For i = 1 To ws_B_lastCol 'for each data
SourceCol_A = NameList_A(UCase(.Cells(1, i).Value)) 'get the column where the name is in Sheet A from the dictionaary
If SourceCol_A <> 0 Then 'if 0 means the name doesnt exists
SourceLastRow = ws_A.Cells(Rows.Count, SourceCol_A).End(xlUp).Row
Set Source = ws_A.Range(ws_A.Cells(SourceDataStart, SourceCol_A), ws_A.Cells(SourceLastRow, SourceCol_A))
NextEntryline = .Cells(Rows.Count, i).End(xlUp).Row + 1 'get the next entry line of the particular name in sheet A
.Range(.Cells(NextEntryline, i), _
.Cells(NextEntryline, i)) _
.Resize(Source.Rows.Count, Source.Columns.Count).Cells.Value = Source.Cells.Value
End If
Next i
End With
End Sub
Good Morning,
I am looking to build a macro to move data between 2 Sheets
In the first sheet, I have data from my manufacture which I called that sheet "original"
In my second Sheet, I called "Finished".
I want to move Data from Original to Finished
In my Original sheet, those headers are not aligned nor are they named the same as in my finished sheet.
in My original sheet, I have a column D which has 3 types of products "Parent, Product Variant, and Standard" so depending on which type of product that data has to be moved into different cells.
So I may need to move original A1 to finished H1 because the match is standard
But if the Match is Parent I may need to move original A1 to C1
or if the match is Product Variation I might need to move A1 to I1
So I am trying to simplify this process
I also may have to merge cells depending on if it is Standard, Parent or Product Variant so I might have data in A1, F1 and AA 1 that have to merged together with a "," or "/" in between
Thanks for any help on pointing me in the right direction for the macro that can help me sort this
Sub Kroll()
Dim i As Long
lastrow lastrow = Sheets("Original").Range("A" & Rows.Count).End(xlUp).row
Sheets("Standard").Range("A2:I999999").ClearContents
For i = 2 To lastrow
If Sheets("original").Cells(i, "D").Value = "Parent Product" Then
Sheets("original").Cells(i, "E").EntireRow.Copy _
Destination:=Sheets("Standard").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
End Sub
I've provided some code which may help you moving some data assuming column D is something like in the picture provided. For the merging problem you have to provide some more detailed explanation and example on what you want being merged.
Picture assumed Column D
Option Explicit
Sub Moving_Exact_Data()
'''https://stackoverflow.com/questions/51348750/moving-exact-data'''
Dim originalSheet As Worksheet
Dim finishedSheet As Worksheet
Dim lastRow As Integer
Dim productRange As Range
Dim i As Integer
'Assuming original sheet is Sheet1
Set originalSheet = Sheet1
'Assuming finished sheet is Sheet2
Set finishedSheet = Sheet2
lastRow = originalSheet.Range("D" & Rows.Count).End(xlUp).Row
For i = 1 To lastRow
With originalSheet
If .Cells(i, 4) = "Parent" Then
finishedSheet.Cells(i, 3) = .Cells(i, 4)
ElseIf .Cells(i, 4) = "Product Variant" Then
finishedSheet.Cells(i, 9) = .Cells(i, 4)
ElseIf .Cells(i, 4) = "Standard" Then
finishedSheet.Cells(i, 8) = .Cells(i, 4)
Else
MsgBox ("no match")
End If
End With
Next i
End Sub
I am writing a script where I want to enable a search in a Database, presenting the results of the search queries in a different worksheet (which I have named Results), so that users do not have access to the whole database at the same time.
In order to do this I want to copy values from the "Database" worksheet into the "Results" worksheet. I have succeeded in selecting the right data from the "Database", in respect to any specific search criteria. I did this with the following code:
With Sheets("Database")
.Range(.Cells(i, 1), .Cells(i, 9)).Copy
End With
Now I want to paste the results into the "Results" spreadsheet and I have done so by writing the following:
Sheets("Results").Range("B600").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
By doing this, I don't quite understand:
if I have strictly defined the paste range as between the first empty row and B600 or;
if I am just defining the beginning of the paste range and, in the case that the search results exceed the 600th row, they will still be pasted after this row.
I ask this because, as the database grows, I will certainly need to guarantee a paste range greater than B600.
I have researched on it but cannot seem to be absolutely sure of what I have done exactly. I must say that I know that the first empty row in the "Results" database will always be 12. In this case, I know that I basically want to paste the search results from the 12th row on. Maybe there is a more straight-forward way to do this.
This is the entire code, for reference:
Private Sub SearchButton_Click()
'This is the search function
'1. declare variables
'2. clear old search results
'3. Find records that match criteria and paste them
Dim country As String
Dim Category As String
Dim Subcategory As String
Dim finalrow As Integer
Dim i As Integer 'row counter
'Erase any entries from the Results sheet
Sheets("Results").Range("B10:J200000").ClearContents
'Deformat any tables in the Results sheet
For Each tbl In Sheets("Results").ListObjects
tbl.Clear
Next
'Define the user-inputed variables
country = Sheets("Results").Range("D5").Value
Category = Sheets("Results").Range("D6").Value
Subcategory = Sheets("Results").Range("D7").Value
finalrow = Sheets("Database").Range("A" & Rows.Count).End(xlUp).Row
'If statement for search
'For every variable i, start comparing from row 2 until the final row
For i = 2 To finalrow
'If the country field is left empty
If country = "" Then
Sheets("Results").Range("B10:J200000").Clear
MsgBox "You must select a country in order to search the database. Please do so in the drop-down list provided."
Sheets("Results").Range("D5").ClearContents
Sheets("Results").Range("D6").ClearContents
Sheets("Results").Range("D7").ClearContents
Exit Sub
'If the country field is filled in and there results from the search made
ElseIf Sheets("Database").Cells(i, 1) = country And _
(Sheets("Database").Cells(i, 3) = Category Or Category = "") And _
(Sheets("Database").Cells(i, 4) = Subcategory Or Subcategory = "") Then
'Copy the headers of the table
With Sheets("Database")
.Range("A1:I1").Copy
End With
Sheets("Results").Range("B10:J10").PasteSpecial
'Copy the rows of the table that match the search query
With Sheets("Database")
.Range(.Cells(i, 1), .Cells(i, 9)).Copy
End With
Sheets("Results").Range("B600").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
'Hides search form
Me.Hide
End If
Next i
'Toggle Results sheet
Sheets("Results").Activate
'Format results as a table
Set rng = Range(Range("B10"), Range("B10").End(xlUp).SpecialCells(xlLastCell))
Set table = Sheets("Results").ListObjects.Add(xlSrcRange, rng, , xlYes)
table.TableStyle = "TableStyleMedium13"
Range("B11").Select
'Make Excel window visible
Application.Visible = True
End Sub
Thank you very much for your help.
You can count from the bottom of the sheet upto the last used cell in column B, and then OFFSET by 1 row. This prevents you needing to worry about
a) that the range to paste to starts from row 12 (they should contain values), and
b) that you are currently using a hard-coded 'anchor' of B600 which will need updating as the data grows.
Sample code:
Dim ws As Worksheet
Dim rngColumnBUsed As Range
Dim lngFirstEmptyRow As Long
Set ws = ThisWorkbook.Sheets("Results")
Set rngColumnBUsed = ws.Range("B" & ws.Rows.Count).End(xlUp).Offset(1, 0)
lngFirstEmptyRow = rngColumnBUsed.Row
Two ListObjects tblDatabase and tblResults
tblResults data gets cleared
A filter is applied to the second, third and fourth columns of tblDatabase
If there are less than 588 results, we copy the filtered records from tblDatabase to tblResults
If there are more than 588 results then we resize the filtered records' range down to the first 588 records and then copy them to tblResults
We never worry about formatting because tblResults keeps it's original format.
Sub ListObjectDemo()
Dim tblDatabase As ListObject, tblResults As ListObject
Set tblDatabase = Worksheets("Database").ListObjects("tblDatabase")
Set tblResults = Worksheets("Results").ListObjects("tblResults")
If Not tblResults.DataBodyRange Is Nothing Then tblResults.DataBodyRange.ClearContents
With tblDatabase.Range
.AutoFilter Field:=2, Criteria1:="Test A"
.AutoFilter Field:=3, Criteria1:="East"
.AutoFilter Field:=4, Criteria1:="Algeria"
End With
With tblDatabase.DataBodyRange
If .Rows.Count <= 588 Then
.Copy tblResults.ListRows.Add.Range
Else
.Resize(588).Copy tblResults.ListRows.Add.Range
End If
End With
End Sub
Dim searchdata as range, inputfromuser as string
inputfromuser = inputbox("type what you wanna search")
set searchdata = sheets("Database").find(inputfromuser).select
searchdata = activecell.value or activecell.offset(10,5).value
sheets("results").activate
with sheets("result")
range("a12",range("a12").end(xldown)).offset(1,0).select
searchdata.copy destination:= activecell
activecell.offset(1,0).select
end with
Not sure, if I understood you corectly mate.
I dont haveexcel sheet or VBE editor. Just wrote this directly on website. Pls amend as per your need.
I need code, as my title suggests, for the following task. I already tried a lot of different code but it's still not working.
I only need to move 2 columns, "SKU" and "Discount", into sheet2 using command button and delete it right away.
I'm already okay for this coding. However, but the problem is just beginning.
When I succeed to moved the first data, and try to move the 2nd data, the 1st data disappears.
I already tried many ways but still can't figure it out what's wrong with the code.
Please check the following code:
Sub OUTGOING_GOODS()
function1
function2
clear
Range_End_Method
End Sub
Sub function1()
Sheets("Invoice Print").Range("B21:B27").Copy Destination:=Sheets("Outgoing Goods").Range("D4")
End Sub
Sub function2()
Sheets("Invoice Print").Range("D21:D27").Copy Destination:=Sheets("Outgoing Goods").Range("L4")
End Sub
Sub clear()
Range("B21:B27").clear
End Sub
I also need to change the range for input data as well. As you can see the Range is defined only from D21:D27, but I need more than row 27 just in case there is additional data inputted.
Already tried the following code:
With Worksheets("Sheet2")
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
LastRow = .Cells(.Rows.Count, "L").End(xlUp).Row
For Each cell In Range("D4:D" & LastRow)
DestinationRow = LastRow + 1
Next
For Each cell In Range("L4:L" & LastRow)
DestinationRow = LastRow + 1
Next
End With
And
Lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 1 To InputData
Lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
For j = 1 To 3
.Cells(lastrow + 1, j).Value = InputData(i, j)
Next j
Next i
End With
This still isn't working.
Based on our discussions thus far I'd suggest the following:
Sub Outgoing_Goods_New()
'
Dim Outgoing As Worksheet 'Generally it's better to use Worksheet variables. Saves the trouble of having to re-type the sheet name each time you reference the sheet
Dim Invoice As Worksheet
Dim LastRow_Invoice As Long
Dim LastRow_Outgoing As Long
Set Outgoing = ActiveWorkbook.Worksheets("Outgoing Goods")
Set Invoice = ActiveWorkbook.Worksheets("Invoice Print")
'Find the last row of Outgoing column D that's used so we know where to paste the new set of outgoing goods
LastRow_Outgoing = Outgoing.Range("D1048576").End(xlUp).Row
'Make sure column L of Outgoing ends at the same point
If Outgoing.Range("L1048576").End(xlUp).Row > LastRow_Outgoing Then
LastRow_Outgoing = Outgoing.Range("L1048576").End(xlUp).Row
End If 'else column L's last used row is farther up the worksheet or the same row. Either way no need to update the value
'Determine how much data to copy
LastRow_Invoice = Invoice.Range("B1048576").End(xlUp).Row 'I'm assuming Column D of Invoice Print has to end at the same row. If not, use the same IF statement as above, but
'checking column D of Invoice
'Copy the data from column B
Invoice.Range("B2:B" & LastRow_Invoice).Copy
'Paste to Outgoing Goods
Outgoing.Range("B" & LastRow_Outgoing).PasteSpecial xlPasteAll
'Copy Column D of Invoice
Invoice.Range("D2:D" & LastRow_Invoice).Copy
Outgoing.Range("L" & LastRow_Outgoing).PasteSpecial xlPasteAll
'Clear the data from Invoice print
Invoice.Range("B2:B" & LastRow_Invoice).ClearContents 'Removes the Value, but leaves formatting, comments, etc. alone
End Sub
This is mostly the logic you already had, but I did some clean-up to remove ambiguities and genericize the logic a little. Also, notice that I didn't keep the separate Subs. With how little you're doing there's just not any benefit to parsing the logic, especially with none of the code being re-used.
Last, I didn't delete column D on Invoice Print assuming that the cells just held formulas that pull in new data based on the values in Column B. If that's not the case, it seems like you should add a second ClearContents to delete Column D as well, but that's not certain given the vagueness of your use case.
how to copy & paste the data from one column to another between two sheets of excel workbook ... without overwriting the destination column content?
I am using below code to copy & paste but every time I run it it is overwriting the existed content. I want to be pasted from next row of the column.
Sub DirectCopySample()
Application.ScreenUpdating = False
Sheets("Updating Sheet").Range("A:A").Copy Destination:=Sheets("Sheet1").Range("G:G")
Sheets("Updating Sheet").Range("B:B").Copy Destination:=Sheets("Sheet1").Range("F:F")
Sheets("Updating Sheet").Range("C:C").Copy Destination:=Sheets("Sheet1").Range("B:B")
Application.ScreenUpdating = True
End Sub
Don't copy the entire column. Copy a specific 1-cell-wide range of X rows (where X is your data) and define all your variables based on the current size of the data. For instance if you want to copy column A from sheet1 to the end of column B in sheet2.
Sub CopyColumn()
Dim wsCopy As Worksheet
Set wsCopy = Sheets("<Sheet Name>")
Dim wsPaste As Worksheet
Set wsPaste = sheets("<Sheet Name>")
'/ Much better to make your worksheets variables and then reference those
Dim lngFirstRow As Long
Dim lngFinalRow As Long
Dim lngCopyColumn As Long
Dim lngPasteColumn As Long
Dim rngCopy As Range
Dim rngPasteCell As Range
lngCopyColumn = 1 '/ ("A" Column)
lngDestinationColumn = 2 '/ ("B" Column)
wsCopy.Activate
lngFirstRow = 1
lngFinalRow = Cells(1048576, lngCopyColumn).End(xlUp).Row
'/ Starts at the bottom of the sheet, stops at the first cell with data in it, returns that cell's row
Set rngCopy = Range(Cells(lngFirstRow, lngCopyColumn), Cells(lngFinalRow, lngCopyColumn))
'/ Defines the range between those 2 cells
rngCopy.copy
wsPaste.Activate
lngFinalRow = Cells(1048576, lngPasteColumn).End(xlUp).Row
Set rngpaste = Cells(lngFinalRow + 1, lngPasteColumn)
'/ Pastes to the row 1 cell below the last filed cell in Column B
rngpaste.Paste
End Sub
#Grade 'Eh' Bacon outlined the correct process in his or her comment.
The crux of the issue is finding the size of the ranges you are copying from and pasting to. My current favorite method of doing so is the code snippet below:
copyLastrow = Sheets("Updating Sheet").Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
That will find the last non-empty row in your worksheet. So if for some reason column A has 100 rows, B has 200 rows, and C has 300 rows it will return 300 as the last row.
On the paste side of things, you could use the same method and add 1 to it so you paste into the first empty row, but if the columns have different numbers of rows you will end up with many blank rows in the shorter columns before your data is pasted at the bottom.
A work around this is the following code:
pasteLastrowG = Sheets("Sheet1").Range("G" & Rows.Count).End(xlUp).Row + 1
This will start at the bottom of column G and head up until it hits a row with data in it and then add 1 so that you are pasting into the first blank row of the column. You could then create variables for columns H and I that do the same thing.
Putting it all together your code would look something like this in the end:
copyLastrow = Sheets("Updating Sheet").Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
pasteLastrowG = Sheets("Sheet1").Range("G" & Rows.Count).End(xlUp).Row + 1
'pasteLastrowH ...
'pasteLastrowI ...
Sheets("Updating Sheet").Range("A2:A" & copyLastrow).Copy Destination:=Sheets("Sheet1").Range("G" & pasteLastrowG)
'Copy and paste B code here
'Copy and paste C code here