I have 4 sheets of data with thousands of rows in each sheet. There is one column within each sheet that I would like to consolidate into a 5th sheet. In this column, I'd like to make sure that every name from the previous four sheets is included in one comprehensive list with no repeats.
See a simple example below, but imagine 20,000 rows on each sheet with complex names. Can anyone think of a method of doing this, that does not require tweaking everytime the inputs change? I've been trying to use PivotChart Wizard with no luck.
Sheet 1 Sheet 2 Sheet 3 Sheet 4 Ideal Sheet 5
Dog Cat Fish Giraffe Dog
Hamster Dog Lhama Cat Cat
Giraffe Elephant Dog Fish Fish
Giraffe
Elephant
Hamster
Lhama
Here is the code I came up with to solve the problem in case anyone is interested. "Zone & Fam" just specifies the column I'm interested in.
Sub GetUniqueZoneFam()
Application.ScreenUpdating = False
Dim Lastrow As Long
Worksheets("Calculation Indv").Range("A:A").ClearContents
Worksheets("fcst fg").Activate
Range("Fcst_Fg[Zone & Fam]").Copy
Worksheets("Calculation Indv").Activate
Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Worksheets("fcst ps").Activate
Range("Fcst_PS[Zone & Fam]").Copy
Worksheets("Calculation Indv").Activate
Range("A" & Lastrow + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Worksheets("sales fg").Activate
Range("Sales_FG[Zone & Fam]").Copy
Worksheets("Calculation Indv").Activate
Range("A" & Lastrow + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Worksheets("sales ps").Activate
Range("Sales_PS[Zone & Fam]").Copy
Worksheets("Calculation Indv").Activate
Range("A" & Lastrow + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Application.CutCopyMode = False
Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
Range("A1").Select
Worksheets("Calculation Indv").Range("A1").Value = "Zone & Fam"
Worksheets("Calculation Indv").Range("A1").Font.Bold = True
Application.ScreenUpdating = True
MsgBox ("Done!")
End Sub
In vba this would look something like the following (Totally not tested, written outside of VBE, probably riddled with mistakes, definitely will need tweaking to fit your sheet names and columns where your data lives):
Dim wsName as String
Dim lastRow as Long
Dim writeRow as Long
'set the row on which we are going to start writing data to "Sheet 5"
writeRow = 1
'Loop though your sheets to copy from
For Each wsName In Array("Sheet 1", "Sheet 2", "Sheet 3", "Sheet 4")
'determine the last used row in the worksheet we are copying from
lastRow = Sheets(wsName).Range("A1").End(xlDown).Row
'grab the data
Sheets(wsName).Range("A1:A" & lastRow).Copy Destination:=Sheets("Sheet 5").Range("A" & writeRow)
'increment the writeRow
writeRow = writeRow + lastRow
Next wsName
'Now that all the data is copied, dedup it
Sheets("Sheet 5").Range("A1:A" & writeRow).RemoveDuplicates Columns:=Array(1), Header:=xlNo
Sub GetUniqueZoneFam()
Application.ScreenUpdating = False
Dim Lastrow As Long
Worksheets("Calculation Indv").Range("A:A").ClearContents
Worksheets("fcst fg").Activate
Range("Fcst_Fg[Zone & Fam]").Copy
Worksheets("Calculation Indv").Activate
Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Worksheets("fcst ps").Activate
Range("Fcst_PS[Zone & Fam]").Copy
Worksheets("Calculation Indv").Activate
Range("A" & Lastrow + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Worksheets("sales fg").Activate
Range("Sales_FG[Zone & Fam]").Copy
Worksheets("Calculation Indv").Activate
Range("A" & Lastrow + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Worksheets("sales ps").Activate
Range("Sales_PS[Zone & Fam]").Copy
Worksheets("Calculation Indv").Activate
Range("A" & Lastrow + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Application.CutCopyMode = False
Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
Range("A1").Select
Worksheets("Calculation Indv").Range("A1").Value = "Zone & Fam"
Worksheets("Calculation Indv").Range("A1").Font.Bold = True
Application.ScreenUpdating = True
MsgBox ("Done!")
End Sub
Related
I copy data from "database" and paste it to another sheet.
Macro takes the names from the list in Sheet1 and looks for matches in Sheet2.
When the match is found it is copying a specific cell.
I have a macro for each person on the list so I have five macros doing the same thing so maybe that why it takes so much time (around three minutes).
Is there any way to make it faster?
Sub CopySalesMan1()
Dim lastrow As Long, erow As Long
lastrow = Worksheets("Sheet2").Cells(Rows.Count, 2).End(xlUp).Row
For i = 2 To lastrow
If Worksheets("Sheet2").Cells(i, 25).Value = Worksheets("Sheet1").Cells(6, 12).Value Then
Worksheets("Sheet2").Cells(i, 2).Copy
erow = Worksheets("Sheet1").Cells(Rows.Count, 4).End(xlUp).Row
Worksheets("Sheet1").Cells(erow + 1, 3).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Worksheets("Sheet2").Cells(i, 25).Copy
Worksheets("Sheet1").Cells(erow + 1, 4).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Worksheets("Sheet2").Cells(i, 3).Copy
Worksheets("Sheet1").Cells(erow + 1, 5).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Worksheets("Sheet2").Cells(i, 4).Copy
Worksheets("Sheet1").Cells(erow + 1, 6).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Worksheets("Sheet2").Cells(i, 5).Copy
Worksheets("Sheet1").Cells(erow + 1, 7).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Worksheets("Sheet2").Cells(i, 6).Copy
Worksheets("Sheet1").Cells(erow + 1, 8).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Worksheets("Sheet2").Cells(i, 21).Copy
Worksheets("Sheet1").Cells(erow + 1, 9).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
Next i
End Sub
And the macro calling for every salesman in the list
Sub All()
If Worksheets("Sheet1").Range("L7").Value <> "" Then Call CopySalesMan2
If Worksheets("Sheet1").Range("L8").Value <> "" Then Call CopySalesMan3
If Worksheets("Sheet1").Range("L9").Value <> "" Then Call CopySalesMan4
If Worksheets("Sheet1").Range("L10").Value <> "" Then Call CopySalesMan5
End Sub
Sheet1
Sheet2 (database)
I got the solution:
as braX said .value = .value will be better option
Sub CopySalesMan()
Application.ScreenUpdating = False
Dim XlWkSht As Worksheet, sVal As String, lRow As Long, i As Long, r As Long
Set XlWkSht = Worksheets("Sheet1")
lRow = XlWkSht.Range("D" & XlWkSht.Rows.Count).End(xlUp).Row
For i = 6 To 10
If XlWkSht.Range("L" & i).Value <> "" Then
sVal = XlWkSht.Range("L" & i).Value
With Worksheets("Sheet2")
For r = 2 To .Range("B" & .Rows.Count).End(xlUp).Row
If .Range("Y" & r).Value2 = sVal Then
lRow = lRow + 1
XlWkSht.Range("B" & lRow).Value = .Range("B" & r).Value
XlWkSht.Range("C" & lRow).Value = .Range("Y" & r).Value
XlWkSht.Range("D" & lRow).Value = .Range("C" & r).Value
XlWkSht.Range("E" & lRow).Value = .Range("D" & r).Value
XlWkSht.Range("F" & lRow).Value = .Range("E" & r).Value
XlWkSht.Range("G" & lRow).Value = .Range("F" & r).Value
XlWkSht.Range("H" & lRow).Value = .Range("U" & r).Value
End If
Next r
End With
End If
Next
Application.ScreenUpdating = True
End Sub
I have some VBA code that works fine, however I'm trying to improve my code by losing the select commands. I am learning that this is not best practice. The (old) code that works is below:
With Sheets("Data")
RowCount = .Cells(.Rows.Count, "B").End(xlUp).Row
For i = 1 To RowCount
Range("B1").Offset(1, 0).Select
If ActiveCell.Offset(0, -1).Value = 2 And ActiveCell.Value = sPeril Then
ActiveSheet.Cells.Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("DynamicCharts").Select
Sheets("DynamicCharts").Range("E" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Data").Select
End If
next i
End With
The code switches between sheets copying and pasting using offset cells. Ive tried to change this with a WITH command and its debugging on the paste command.
With Sheets("Data")
RowCount = .Cells(.Rows.Count, "B").End(xlUp).Row
For i = 1 To RowCount
Range("B1").Offset(1, 0).Select
If ActiveCell.Offset(0, -1).Value = 1 And ActiveCell.Value = sPeril Then
ActiveSheet.Cells.Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
With Sheets("DynamicCharts")
.Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End With
'Sheets("EDM Data").Select
End If
next i
End With
Any help on this would be much appreicated.
Thanks in advance
Give this a shot instead - this completely removes the need for Select. We could also get rid of Copy/Paste as well, but I need to know what you're trying to bring over (maybe it's format specific?). Please include more of your code when asking a question (like what sPeril is, etc.):
Dim destrow As Long, lastcol As Long
With Sheets("Data")
RowCount = .Cells(.Rows.Count, "B").End(xlUp).Row
For i = 2 To RowCount
If Range("B" & i).Offset(0, -1).Value = 2 And Range("B" & i).Value = sPeril Then
destrow = Sheets("DynamicCharts").Cells(Sheets("DynamicCharts").Rows.Count, "E").End(xlUp).Row
lastcol = Sheets("Data").Cells(i, Sheets("Data").Columns.Count).End(xlToLeft).Column
Sheets("Data").Range(Sheets("Data").Cells(i, 2), Sheets("Data").Cells(i, lastcol)).Copy
Sheets("DynamicCharts").Range("E" & destrow + 1).PasteSpecial
End If
Next i
End With
your code but with a simple fix just look at the comment. Note I set peril to 2 just so that i can make the code fall into that condition.
Sub test2()
With Sheets("sheet1")
RowCount = .Cells(.Rows.Count, "B").End(xlUp).Row
For i = 1 To RowCount
Range("B1").Offset(1, 0).Select
sPeril = 2
If ActiveCell.Offset(0, -1).Value = 1 And ActiveCell.Value = sPeril Then
ActiveSheet.Cells.Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
With Sheets("DynamicCharts")
'remove selection on this line.
.Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End With
'Sheets("EDM Data").Select
End If
Next i
End With
End Sub
I have a sheet with a range of A12:N112, Column A is my trigger column (1 or ) based on changing criteria). The first bit of my macro which works sorts this range to all the rows with a 1 are at the top of the range. It then opens the destination sheet as well.
The next bit of code below, needs to copy cells B:L for each row with a 1 in column A and paste that into the first empty row in the destination sheet starting at column D. This then generates a number which the then copied and pasted back into the first sheet in column M of that specific row. This then needs to loop until all of the rows with a 1 in column A have been processed.
Can anyone help, here is my code, which runs but nothing is copied or pasted.
Dim lr As Long lr = Sheets("Data Entry").Cells(Rows.Count, "A").End(xlUp).Row
For r = lr To 2 Step 1
If Range("AB" & r).Value = "1" Then
Rows(r).Copy.Range ("A" & lr2 + 1)
Windows("Serialisation Log.xlsx").Activate
Sheets("SNo Log").Select
Range("D" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Windows("Serialisation Log.xlsx").Activate
Sheets("SNo Log").Select
Range("A" & Rows.Count).End(xlUp).Offset(-1).Select
Selection.Copy
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
Range("A" & Rows.Count).End(xlUp).Offset(0).Select
Selection.Copy
Windows("Serialisation Generator rev 1.xlsm").Activate
Worksheets("Data Entry").Select
Range("N").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
If Range("AB" & r).Value = "0" Then
Range("I4").Select
ActiveCell.FormulaR1C1 = "Serial No. Issue complete for this OA"
End If
Range("F5").Select
Next r
Any help will be greatly appreciated.
I am trying to run a macro that copy three tables from different worksheets and paste it together in a new worksheet.
The number of rows in the tables are not always the same. Therefore, I need a macro with a 'dynamic' "LastRow" parameter so that every time I update one single table the result of the macro is updated.
I tried to run this macro:^
Dim lastRow As Long
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets("Discussed Files").Select
Range("Table1[#Headers]").Select
Selection.Copy
Sheets("All data").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Discussed Files").Select
Range("Table1").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("All data").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Files within 3 Days").Select
Range("Table3").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("All data").Select
Range("A" & lastRow).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Files 10.04.17").Select
Range("Table5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("All data").Select
Range("A" & lastRow).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$Y$" & lastRow), , xlYes).Name = _
"Table14"
Range("Table14[#All]").Select
ActiveSheet.ListObjects("Table14").TableStyle = "TableStyleMedium2"
I cannot understand exactly what the macro is doing. It ends up woth a table having number of rows equal to first sheet but data inside the table are 'randomly' taken from the other sheets.
Moreover, the selection to make the result a table is not working properly.
As per comment above (have also removed unnecessary Selects)
Sub x()
Dim lastRow As Long
With Sheets("All data")
Sheets("Discussed Files").Range("Table1[#All]").Copy
.Range("A1").PasteSpecial Paste:=xlPasteValues
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
Sheets("Files within 3 Days").Range("Table3").Copy
.Range("A" & lastRow).PasteSpecial Paste:=xlPasteValues
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
Sheets("Files 10.04.17").Range("Table5").Copy
.Range("A" & lastRow).PasteSpecial Paste:=xlPasteValues
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
.ListObjects.Add(xlSrcRange, .Range("$A$1:$Y$" & lastRow), , xlYes).Name = "Table14"
.ListObjects("Table14").TableStyle = "TableStyleMedium2"
End With
End Sub
You don't update lastRow between steps, so you are basically pasting them one over another into same spot because the lastRow does not update after you paste one of your tables, it retains the same value from the beginning of your code in each:
Range("A" & lastRow).Select
Selection.PasteSpecial
Also, this code will return last row with data in it so if you are pasting into clean sheet, you are pasting all tables into the same spot:
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
EDIT:
Dim lastRow As Long
lastRow = Sheets("All data").Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets("Discussed Files").Range("Table1[#All]").Select
Selection.Copy
Sheets("All data").Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
lastRow = Sheets("All data").Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets("Files within 3 Days").Range("Table3").Select
Selection.Copy
Sheets("All data").Range("A" & lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
lastRow = Sheets("All data").Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets("Files 10.04.17").Range("Table5").Select
Selection.Copy
Sheets("All data").Range("A" & lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
lastRow = Sheets("All data").Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets("All data").ListObjects.Add(xlSrcRange, Range("$A$1:$Y$" & lastRow), , xlYes).Name = _
"Table14"
Range("Table14[#All]").Select
Sheets("All data").ListObjects("Table14").TableStyle = "TableStyleMedium2"
This is what I have:
I am trying to get excel to copy only the cells that i have selected and pasted on the next blank line in another spreadsheet.
But in the code below, it fixed the range of cell being copied. How should i change my code so that it can be a dynamic range?
Sub CopyPaste()
Range("A6:E6").Select
Selection.Copy
Sheets("Sheet2").Select
lMaxRows = Cells(Rows.Count, "A").End(xlUp).Row
Range("A" & lMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
lMaxRows = Cells(Rows.Count, "A").End(xlUp).Row
Range("A" & lMaxRows + 1).Select
End Sub
Remove the statement
Range("A6:E6").Select
This statement selects the fixed range.
Try this
Sub CopyPaste()
Dim sht As Worksheet
Dim rngTarget As Range
Dim lMaxRows As Long
Selection.Copy
Set sht = Sheets("Sheet2")
lMaxRows = sht.Cells(Rows.Count, "A").End(xlUp).Row
Set rngTarget = sht.Range("A" & lMaxRows + 1)
rngTarget.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
lMaxRows = sht.Cells(Rows.Count, "A").End(xlUp).Row
sht.Activate
sht.Range("A" & lMaxRows + 1).Select
End Sub
I have rewritten the code to specify exactly which cells and ranges are used. If not, it will apply selections on the sheet that is open (active) at that moment.
In my experience, using .Select is error-prone so I try to avoid it as much as possible.