I am trying to copy data from cells F11:Z22 on multiple sheets and output the data onto one summary sheet.
Sample of Data to Copy
There is the possibility to have new sheets added. I would like to get data from those sheets as well.
I have Sheets "SummarySheet", "Import", "TemplateSheet" I do not want to copy data from. The other sheets I do.
The ideal output would be just all of the values listed out in the "Import" sheet.
Example of Result
I tried a few different macros. This one logically works the best. When I execute it, nothing happens.
Sub SummarizeSKUdata()
Dim wksSrc As Worksheet, wksDst As Worksheet
Dim rngSrc As Range, rngDst As Range
Dim lngLastCol As Long, lngSrcLastRow As Long, lngDstLastRow As Long
'Notes: "Src" is short for Source, "Dst" is short for Destination
'Set Referances up-front
Set wksDst = ThisWorkbook.Worksheets("Import")
lngDstLastRow = wksDst.Cells.SpecialCells(xlCellTypeLastCell).Row '<-defined below
lngLastCol = wksDst.UsedRange.Columns(wksDst.UsedRange.Columns.Count).Column '<-defined below
'set the initial destination range
Set rngDst = wksDst.Cells(lngDstLastRow + 1, 1)
'Loop Through all sheets
For Each wksSrc In ThisWorkbook.Worksheets
'Make Sure we skip the Summary Sheet
If wksSrc.Name <> "SummarySheet" Then
If wksSrc.Name <> "Import" Then
If wksSrc.Name <> "TemplateSheet" Then
'Identify the last row occupied on this sheet
lngSrcLastRow = wksDst.Cells.SpecialCells(xlCellTypeLastCell).Row
'Store the source data then copy it to the destination range
With wksSrc
Set rngSrc = Range("F11:Z22")
rngSrc.Copy Destination:=rngDst
End With
'Redefine the destination range now that new data has been added
lngDstLastRow = wksDst.Cells.SpecialCells(xlCellTypeLastCell).Row
Set rngDst = wksDst.Cells(lngDstLastRow + 1, 1)
End If
End If
End If
Next wksSrc
End Sub
I was able to figure it out with this code below.
Sub SummarizeSKUdata()
Dim wksSrc As Worksheet, wksDst As Worksheet
Dim rngSrc As Range, rngDst As Range
Dim lngLastCol As Long, lngSrcLastRow As Long, lngDstLastRow As Long
'Notes: "Src" is short for Source, "Dst" is short for Destination
'Set Referances up-front
Set wksDst = ThisWorkbook.Worksheets("Import")
wksDst.Rows("2:" & Rows.Count).ClearContents
'set the initial destination range
Set rngDst = wksDst.Cells(lngDstLastRow + 2, 1)
'Loop Through all sheets
For Each wksSrc In ThisWorkbook.Worksheets
lngDstLastRow = wksDst.Cells.SpecialCells(xlCellTypeLastCell).Row '<-defined below
lngLastCol = wksDst.UsedRange.Columns(wksSrc.UsedRange.Columns.Count).Column '<-defined below
'Make Sure we skip the Summary Sheet
If wksSrc.Name <> "SummarySheet" Then
If wksSrc.Name <> "Import" Then
If wksSrc.Name <> "TemplateSheet" Then
'Identify the last row occupied on this sheet
lngSrcLastRow = wksDst.Cells.SpecialCells(xlCellTypeLastCell).Row
'Store the source data then copy it to the destination range
With wksSrc
wksSrc.Range("F11:Z22").Copy
rngDst.PasteSpecial Paste:=xlPasteValues
End With
'Redefine the destination range now that new data has been added
lngDstLastRow = wksDst.Cells.SpecialCells(xlCellTypeLastCell).Row
Set rngDst = wksDst.Cells(lngDstLastRow + 1, 1)
End If
End If
End If
Next wksSrc
End Sub
Related
I currently have a macro that merges all the tabs except for a tab named "Combined". This combined sheet will be the destination of the merging of all tabs/sheets. However, I want to exclude some of the tabs from being combined.
For example, I have 5 tabs: Combined, tab1, tabA, tab2, tabB. All tabs have similar number of columns/column headers. When I run the macro it will merge tab1, tabA, tab2, and tabB into Combined. What I want to revise with my current macro is to only combine tab1 and tabA. How will I need to change my current macro?
Here is my current macro:
Option Explicit
Public Sub CombineDataFromAllSheets()
Sheets("Combined").Rows("2:" & Sheets("Combined").Rows.Count).ClearContents
Dim wksSrc As Worksheet, wksDst As Worksheet
Dim rngSrc As Range, rngDst As Range
Dim lngLastCol As Long, lngSrcLastRow As Long, lngDstLastRow As Long
'Notes: "Src" is short for "Source", "Dst" is short for "Destination"
'Set references up-front
Set wksDst = ThisWorkbook.Worksheets("Combined")
lngDstLastRow = LastOccupiedRowNum(wksDst) '<~ defined below (and in Toolbelt)!
lngLastCol = LastOccupiedColNum(wksDst) '<~ defined below (and in Toolbelt)!
'Set the initial destination range
Set rngDst = wksDst.Cells(lngDstLastRow + 1, 1)
'Loop through all sheets
For Each wksSrc In ThisWorkbook.Worksheets
'Make sure we skip the "Import" destination sheet!
If wksSrc.Name <> "Combined" Then
'Identify the last occupied row on this sheet
lngSrcLastRow = LastOccupiedRowNum(wksSrc)
'Store the source data then copy it to the destination range
With wksSrc
Set rngSrc = .Range(.Cells(2, 1), .Cells(lngSrcLastRow, lngLastCol))
rngSrc.Copy Destination:=rngDst
End With
'Redefine the destination range now that new data has been added
lngDstLastRow = LastOccupiedRowNum(wksDst)
Set rngDst = wksDst.Cells(lngDstLastRow + 1, 1)
End If
Next wksSrc
End Sub
Define an array with the sheet names and then iterate this array
Dim arrSheets(1) as String
arrSheets(0) = "tab1"
arrSheets(1) = "tabA"
Dim i as long
For i = 0 to Ubound(arrSheets)
Set wksSrc = Thisworkbook.worksheets(arrSheets(i))
....
next
BTW 1: Avoid implicit referencing of sheets and ranges - always use explicit referencing, like thisworkbook.worksheets or wksSrc.range(...)
BTW 2: You don't need copy/paste - just write the values to the target:
With rngSrc
rngDst.Resize(.Rows.Count, .Columns.Count).Value = .Value 'this is much faster and you don't need the clipboard
End With
#Ike offered a great answer. Theirs and mine are two variations on the same idea: Create a list of sheets to work on, and then loop through that instead of through all sheets in the workbook.
I also cleaned up some other parts to better implement this new idea. Here is the revised code:
Option Explicit
Public Sub CombineDataFromAllSheets()
Dim wksSrc As Variant, wksDst As Worksheet
Dim rngSrc As Range, rngDst As Range
Dim lngLastCol As Long, lngSrcLastRow As Long, lngDstLastRow As Long
Dim SourceSheets As Variant
'Notes: "Src" is short for "Source", "Dst" is short for "Destination"
'Set references up-front
Set wksDst = ThisWorkbook.Worksheets("Combined")
lngDstLastRow = LastOccupiedRowNum(wksDst) '<~ defined below (and in Toolbelt)!
lngLastCol = LastOccupiedColNum(wksDst) '<~ defined below (and in Toolbelt)!
'List of sheets to operate on
SourceSheets = Array( _
ThisWorkbook.Worksheets("tab1"), _
ThisWorkbook.Worksheets("tabA") _
)
wksDst.Rows("2:" & Sheets("Combined").Rows.Count).ClearContents
'Set the initial destination range
Set rngDst = wksDst.Cells(lngDstLastRow + 1, 1)
'Loop through all sheets
For Each wksSrc In SourceSheets
'Identify the last occupied row on this sheet
lngSrcLastRow = LastOccupiedRowNum(wksSrc)
'Store the source data then copy it to the destination range
With wksSrc
Set rngSrc = .Range(.Cells(2, 1), .Cells(lngSrcLastRow, lngLastCol))
rngSrc.Copy Destination:=rngDst
End With
'Redefine the destination range now that new data has been added
lngDstLastRow = LastOccupiedRowNum(wksDst)
Set rngDst = wksDst.Cells(lngDstLastRow + 1, 1)
Next wksSrc
End Sub
I want to copy all the rows and columns in multiple worksheets in a one workbook to a single worksheet in a different workbook. In addition, I just want to copy the header once, even though it is in all of the worksheets I'll copy.
I can open the workbook containing all of the worksheets I want to copy to my destination worksheet/workbook however, I don't know how to copy the header only once and often get a Paste Special error.
Sub Raw_Report_Import()
'Define variables'
Dim ws As Worksheet
Dim wsDest As Worksheet
'Set target destination'
Set wsDest = Sheets("Touchdown")
'For loop to copy all data except headers'
For Each ws In ActiveWorkbook.Sheets
'Ensure worksheet name and destination tab do not have same name'
If ws.Name <> wsDest.Name Then
ws.Range("A2", ws.Range("A2").End(xlToRight).End(xlDown)).Copy
wsDest.Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues
End If
Next ws
End Sub
Expected: All of the target worksheets from second workbook are copied and pasted to destination worksheet "Touchdown" in first workbook and the header is copied only once.
Actual: Some values are paste but the formatting is wrong from what they were and it is not lining up correctly.
There are a number of things wrong with your code. Please find below code (not tested). Please note the differences so you can improve.
Note, when setting the destination worksheet, I would include the workbook object (if in a different workbook). This will prevent errors from occurring. Also note that this code should be run in the OLD workbook. Additionally, I assume your headers are in Row 1 in each sheet, as such I have included headerCnt to take this into consideration and only copy the headers once.
Option Explicit
Sub Raw_Report_Import()
Dim ws As Worksheet
Dim wsDest As Worksheet
Dim lCol As Long, lRow As Long, lRowTarget As Long
Dim headerCnt As Long
'i would include the workbook object here
Set wsDest = Workbooks("NewWorkbook.xlsx").Sheets("Touchdown")
For Each ws In ThisWorkbook.Worksheets
'this loops through ALL other sheets that do not have touch down name
If ws.Name <> wsDest.Name Then
'need to include counter to not include the header
'establish the last row & column to copy
lCol = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column
lRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
'establish the last row in target sheet
lRowTarget = wsDest.Range("A" & wsDest.Rows.Count).End(xlUp).Row + 1
If headerCnt = 0 Then
'copy from Row 1
ws.Range(ws.Cells(1, 1), ws.Cells(lRow, lCol)).Copy
Else
'copy from row 2
ws.Range(ws.Cells(2, 1), ws.Cells(lRow, lCol)).Copy
End If
wsDest.Range("A" & lRowTarget).PasteSpecial xlPasteValues
'clear clipboard
Application.CutCopyMode = False
'header cnt
headerCnt = 1
End If
Next ws
End Sub
Try it like this.
Sub CopyDataWithoutHeaders()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Delete the sheet "RDBMergeSheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
'Fill in the start row
StartRow = 2
'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
'Find the last row with data on the DestSh and sh
Last = LastRow(DestSh)
shLast = LastRow(sh)
'If sh is not empty and if the last row >= StartRow copy the CopyRng
If shLast > 0 And shLast >= StartRow Then
'Set the range that you want to copy
Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If
'This example copies values/formats, if you only want to copy the
'values or want to copy everything look below example 1 on this page
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
All details are here.
https://www.rondebruin.nl/win/s3/win002.htm
I have a problem with VBA code not pasting values
The code goes as following
Set rngSrc = .Range("D29")
rngSrc.Copy Destination:=rngDst
The problem is that I get only #REF errors since the VBA tries to paste whatever the cell has but I would like it to paste special values and I cant make it work with paste special function.
Does someone know how to make it work?
You're almost there, but instead of the Destination method, you should be using PasteSpecial instead, check this nifty code below:
Private Sub copypaste()
Dim rngSrc As Range
Dim rngDest As Range
Dim ws As Worksheet: Set ws = Sheets("Your sheet name")
Set rngSrc = ws.Range("D29")
Set rngDest = ws.Range("A33") ' for example
rngSrc.Copy
rngDest.PasteSpecial xlPasteValues
End Sub
I feel like the code is pretty self-explanatory. Though if you have any questions, let me know
Your CombineDataFromAllSheets code should be:
Public Sub CombineDataFromAllSheets()
Dim wksSrc As Worksheet, wksDst As Worksheet
Dim rngSrc As Range, rngDst As Range
Dim lngLastCol As Long, lngSrcLastRow As Long, lngDstLastRow As Long
Set wksDst = ThisWorkbook.Worksheets("Import")
For Each wksSrc In ThisWorkbook.Worksheets
'These need updating on each pass of the loop.
'Set them at the start, rather than before the loop
'and at the end of the loop.
lngDstLastRow = LastOccupiedRowNum(wksDst)
lngLastCol = LastOccupiedColNum(wksDst)
Set rngDst = wksDst.Cells(lngDstLastRow + 1, 1)
If wksSrc.Name <> "Import" Then
lngSrcLastRow = LastOccupiedRowNum(wksSrc)
With wksSrc
Set rngSrc = .Range("D29")
rngSrc.Copy
rngDst.PasteSpecial xlPasteValues
End With
End If
Next wksSrc
End Sub
How to add a counter for every new sheet combine?
Red is the 1st sheet combine
Yellow is the 2nd sheet combine
Green is the 3rd sheet combine
No need to add color .... however i been trying to add a counter in but i do not know how to do it ... and place it above each data imported
it might be my way of using the macro wrongly ...
hope someone helps me out ....
image
Sub GetSheets()'Update Excel Junction.com
Path = "C:\Users\momo\Desktop\Miscellaneous Shipment Packing List\New folder\"
Filename = Dir(Path & "*.xls")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
End Sub
Sub CombineDataFromAllSheets()
Dim wksSrc As Worksheet, wksDst As Worksheet
Dim rngSrc As Range, rngDst As Range
Dim lngLastCol As Long, lngSrcLastRow As Long, lngDstLastRow As Long
'Notes: "Src" is short for "Source", "Dst" is short for "Destination"
'Set references up-front
Set wksDst = ThisWorkbook.Worksheets("Combine")
lngDstLastRow = LastOccupiedRowNum(wksDst) '<~ defined below (and in Toolbelt)!
lngLastCol = LastOccupiedColNum(wksDst) '<~ defined below (and in Toolbelt)!
'Set the initial destination range
Set rngDst = wksDst.Cells(lngDstLastRow + 1, 2)
'Loop through all sheets
For Each wksSrc In ThisWorkbook.Worksheets
'Make sure we skip the "Import" destination sheet!
If wksSrc.Name <> "Combine" Then
'Identify the last occupied row on this sheet
lngSrcLastRow = LastOccupiedRowNum(wksSrc)
'Store the source data then copy it to the destination range
With wksSrc
Set rngSrc = .Range(.Cells(2, 6), .Cells(lngSrcLastRow, lngLastCol))
rngSrc.Copy Destination:=rngDst
End With
'Redefine the destination range now that new data has been added
lngDstLastRow = LastOccupiedRowNum(wksDst)
Set rngDst = wksDst.Cells(lngDstLastRow + 2, 1)
End If
Next wksSrc
End Sub
'''''''''''''''''
'INPUT : Sheet, the worksheet we'll search to find the last row
'OUTPUT : Long, the last occupied row
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
Dim lng As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
With Sheet
lng = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End With
Else
lng = 1
End If
LastOccupiedRowNum = lng
End Function
''''''''''''''''''''''''''''''''
'INPUT : Sheet, the worksheet we'll search to find the last column
'OUTPUT : Long, the last occupied column
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedColNum(Sheet As Worksheet) As Long
Dim lng As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
With Sheet
lng = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
End With
Else
lng = 1
End If
LastOccupiedColNum = lng
End Function
The simplest approach is to add a static counter, but this will be reset each time you open the workbook. The more resilient approach will be to find the last counter and add one.
I am not able to create fully tested code here, but the following should give enough of an idea. Remember that proper indenting and Option Explicit are your friends. Also, I have not put any other optimisations in your code - e.g. check how many times you really need to set your destination range and where it is best to set it.
Sub CombineDataFromAllSheets()
Dim importCounter as Long '**** Added this
Dim wksSrc As Worksheet, wksDst As Worksheet
Dim rngSrc As Range, rngDst As Range
Dim lngLastCol As Long, lngSrcLastRow As Long, lngDstLastRow As Long
'Notes: "Src" is short for "Source", "Dst" is short for "Destination"
'Set references up-front
Set wksDst = ThisWorkbook.Worksheets("Combine")
lngDstLastRow = LastOccupiedRowNum(wksDst) '<~ defined below (and in Toolbelt)!
lngLastCol = LastOccupiedColNum(wksDst) '<~ defined below (and in Toolbelt)!
'Set the initial destination range
Set rngDst = wksDst.Cells(lngDstLastRow + 1, 2)
'**** Find and set the Counter - not tested for error conditions (what if the sheet is empty?)
importCounter = wksDst.Cells(Range("A" & lngDstLastRow).End(xlUp).Row,1)
'Loop through all sheets
For Each wksSrc In ThisWorkbook.Worksheets
'Make sure we skip the "Import" destination sheet!
If wksSrc.Name <> "Combine" Then
'Identify the last occupied row on this sheet
lngSrcLastRow = LastOccupiedRowNum(wksSrc)
'Store the source data then copy it to the destination range
With wksSrc
'**** increment and insert the counter
'**** in order to do this, had to fix rngDst, set it where it is used rather then too early.
Set rngDst = wksDst.Cells(lngDstLastRow + 1, 1)
importCounter = importCounter + 1
rngDst = importCounter
lngDstLastRow = lngDstLastRow + 1
Set rngDst = wksDst.Cells(lngDstLastRow + 1, 2)
Set rngSrc = .Range(.Cells(2, 6), .Cells(lngSrcLastRow, lngLastCol))
rngSrc.Copy Destination:=rngDst
End With
'Redefine the destination range now that new data has been added
lngDstLastRow = LastOccupiedRowNum(wksDst)
Set rngDst = wksDst.Cells(lngDstLastRow + 2, 1)
End If
Next wksSrc
End Sub
Would like to create a Macro to loop through all of the sheets in the workbook and select all the data from each worksheet and then paste said data into a single consolidate table on the "Master" sheet. All sheets have the same column heading to Column "AB".
Currently tried using this code but I have been unable to get anything to paste over onto the Master worksheet. Might be overthinking setting the range each tab.
Just looking for a simple solution to copy all active data from each sheet and paste it into one sheet so that is its all consolidated.
Thanks in advance!
Sub CombineData()
Dim wkstDst As Worksheet
Dim wkstSrc As Worksheet
Dim WB As Workbook
Dim rngDst As Range
Dim rngSrc As Range
Dim DstLastRow As Long
Dim SrcLastRow As Long
'Refrences
Set wkstDst = ActiveWorkbook.Worksheets("Master")
'Setting Destination Range
Set rngDst = wkstDst.Cells(DstLastRow + 1, 1)
'Loop through all sheets exclude Master
For Each wkstSrc In ThisWorkbook.Worksheets
If wkstSrc.Name <> "Master" Then
SrcLastRow = LastOccupiedRowNum(wkstSrc)
With wkstSrc
Set rngSrc = .Range(.Cells(2, 1), .Cells(SrcLastRow, 28))
rngSrc.Copy Destination:=rngDst
End With
DstLastRow = LastOccupiedRowNum(wkstDst)
Set rngDst = wkstDst.Cells(DstLastRow + 1, 1)
End If
Next wkstSrc
End Sub
Throwing another method into the mix. This does assume that the data you are copying has as many rows in column A as it does in any other column. It doesn't require your function.
Sub CombineData()
Dim wkstDst As Worksheet
Dim wkstSrc As Worksheet
Dim rngSrc As Range
Set wkstDst = ThisWorkbook.Worksheets("Master")
For Each wkstSrc In ThisWorkbook.Worksheets
If wkstSrc.Name <> "Master" Then
With wkstSrc
Set rngSrc = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 28)
rngSrc.Copy Destination:=wkstDst.Cells(Rows.Count, 1).End(xlUp)(2)
End With
End If
Next wkstSrc
End Sub
You have copied this from somewhere else and you have forgotten to copy the function that gets the last row of a worksheet, namely this one LastOccupiedRowNum
So add this function to the same module and the code should work. Please don't forget to mark this as the right answer if it did work:
Function LastOccupiedRowNum(Optional sh As Worksheet, Optional colNumber As Long = 1) As Long
'Finds the last row in a particular column which has a value in it
If sh Is Nothing Then
Set sh = ActiveSheet
End If
LastOccupiedRowNum= sh.Cells(sh.Rows.Count, colNumber).End(xlUp).row
End Function
Try finding the last row dynamically, rather than using .cells
Dim lrSrc as Long, lrDst as Long, i as Long
For i = 1 to Sheets.Count
If Not Sheets(i).Name = "Destination" Then
lrSrc = Sheets(i).Cells( Sheets(i).Rows.Count,"A").End(xlUp).Row
lrDst = Sheets("Destination").Cells( Sheets("Destination").Rows.Count, "A").End(xlUp).Row
With Sheets(i)
.Range(.Cells(2,"A"), .Cells(lrSrc,"AB")).Copy Sheets("Destination").Range(Sheets("Destination").Cells(lrDst+1,"A"),Sheets("Destination").Cells(lrDst+1+lrSrc,"AB"))
End With
End If
Next i
This should replace your sub and the related function.