All I want to do, within the same workbook, is to copy the value from cell B2 in several SELECTED worksheets and paste into column D in another worksheet called "Summary". In addition, I would like to also copy and paste the corresponding worksheet name in Column C. These are the two codes I have so far, both failed, not sure how to fix them, not sure if there is a better way to do it. I am new in VBA. I am sure you will find silly mistakes, please forgive me. Both codes fail under "Run-time error '5' : Invalid procedure call or argument". Any help is highly appreciated.
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim wb As Workbook
Dim DestSh As Worksheet
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb = ThisWorkbook
Set DestSh = wb.Sheets("Summary")
' Loop through worksheets that start with the name "20"
' This section I tested and it works
For Each sh In ActiveWorkbook.Worksheets
If LCase(Left(sh.Name, 2)) = "20" Then
' Specify the range to copy the data
' This portion has also been tested and it works
sh.Range("B2").Copy
' Paste copied range into "Summary" worksheet in Column D
' This is the part that does not work I get:
' Run-time error '5' : Invalid procedure call or argument
With DestSh.Cells("D2:D")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
' This statement will copy the sheet names in the C column.
' I have not been able to check this part since I am stock in the previous step
DestSh.Cells("C2:C").Resize(CopyRng.Rows.Count).Value = sh.Name
End If
Next
ExitTheSub:
Application.Goto Worksheets("Summary").Cells(1)
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Second Code:
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
' Loop through worksheets that start with the name "20"
' This section I tested and it works
For Each sh In ActiveWorkbook.Worksheets
If LCase(Left(sh.Name, 2)) = "20" Then
' Specify the range to copy the data
' This portion has also been tested and it works
sh.Range("B2").Copy
' Paste copied range into "Summary" worksheet in Column D
' This is the part that does not work I get:
' Run-time error '5' : Invalid procedure call or argument
Worksheets("Summary").Cells("D2:D").PasteSpecial (xlPasteValues)
' This statement will copy the sheet names in the C column.
' I have not been able to check this part works since I am stock in the previous step
Worksheets("Summary").Cells("C2:C").Resize(CopyRng.Rows.Count).Value = sh.Name
End If
Next
ExitTheSub:
Application.Goto Worksheets("Summary").Cells(1)
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
I've made changes to your First code:
Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim wb As Workbook
Dim DestSh As Worksheet
Dim LastRow As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb = ThisWorkbook
Set DestSh = wb.Sheets("Summary")
' Loop through worksheets that start with the name "20"
' This section I tested and it works
For Each sh In ActiveWorkbook.Worksheets
If LCase(Left(sh.Name, 2)) = "20" Then
' Specify the range to copy the data
' This portion has also been tested and it works
sh.Range("B2").Copy
LastRow = DestSh.Cells(Rows.Count, "D").End(xlUp).Row + 1 'find the last row of column "D"
' Paste copied range into "Summary" worksheet in Column D
' This is the part that does not work I get:
' Run-time error '5' : Invalid procedure call or argument
'With DestSh.Cells("D2:D") ----> this line is giving error
With DestSh.Cells(LastRow, 4) '----> 4 is for Column "D"
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
' This statement will copy the sheet names in the C column.
' I have not been able to check this part since I am stock in the previous step
LastRow = DestSh.Cells(Rows.Count, "C").End(xlUp).Row + 1 'find the last row of column "C"
'DestSh.Cells("C2:C").Resize(CopyRng.Rows.Count).Value = sh.Name ----> this line is giving error
DestSh.Cells(LastRow, 3).Value = sh.Name '----> 3 is for Column "C"
End If
Next
ExitTheSub:
Application.Goto Worksheets("Summary").Cells(1)
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Related
I have multiple sheets, each with data only in the first two columns:
Column A - ID
Column B - Name
I am trying to consolidate all these sheets into a master sheet. The format of the master sheet should be:
Column A - Sheet Name (From where the data was copied)
Column B - ID
Column C - Name
I have found a site that has code that does more or less this, however, after messing around with it for what feels like an eternity I just cannot get it to work.
The code works, in the sense that it copies the correct range and inputs the sheet name into column A, however, it doesn't stop by the "last row" of the range in the master sheet, it continues to populate the ENTIRE column A and the IF Statement that counts the rows is triggered and I get the msgbox pop up (see below in code). At this point, the code just ends and it does not get a chance to execute for the remaining sheets.
Link to site: https://www.rondebruin.nl/win/s3/win002.htm
Below is the code from the original site, with some minor adjustments for the range I will be using:
Sub CopySheetNameToColumn()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
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"
'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
Last = LastRow(DestSh)
'Fill in the range that you want to copy
Set CopyRng = sh.Range("A:B")
'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 at the example below this macro
CopyRng.Copy
With DestSh.Cells(Last + 1, "B")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "A").Resize(CopyRng.Rows.count).Value = sh.Name
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
Functions:
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
Instead of
Set CopyRng = sh.Range("A:B")
try
Set CopyRng = sh.Range("A1", sh.Range("B" & Rows.Count).End(xlUp))
as the former covers every row of the worksheet, hence the message box and the name running down the whole sheet.
Something like:
Option Explicit
Sub CopySheetNameToColumn()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
Last = GetLastRow(DestSh, 1)
With sh
Set CopyRng = sh.Range("A1:B" & GetLastRow(sh, 1))
End With
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
Else
CopyRng.Copy IIf(Last = 1, DestSh.Cells(1, "B"), DestSh.Cells(Last + 1, "B"))
End If
If Last = 1 Then
DestSh.Cells(Last, "A").Resize(CopyRng.Rows.Count).Value = sh.Name
Else
DestSh.Cells(Last + 1, "A").Resize(CopyRng.Rows.Count).Value = sh.Name
End If
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
With ws
GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
End With
End Function
You can shorten this significantly... there are lots of posts about getting items on a master sheet, 4 from yesterday alone.
Take a look at this:
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, "B")).Copy Sheets("Destination").Range(Sheets("Destination").Cells(lrDst + 1, "B"), Sheets("Destination").Cells(lrDst + 1 + lrSrc, "C")) 'Assumes headers in first row aren't being copied
Sheets("Destination").Range(Sheets("Destination").Cells(lrDst + 1, "A"), Sheets("Destination").Cells(lrDst + 1 + lrSrc, "A")).Value = Sheets(i).Name
End With
End If
Next i
Code now tested
Good Day! I have these code below which it gives me an error of "We can't paste because copy area and paste area arent the same size".. Please help what is wrong with these code... :(
Option Explicit
Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
For Each sh In ActiveWorkbook.Worksheets
If IsError(Application.Match(sh.Name, _
Array(DestSh.Name, "Information"), 0)) Then
Last = LastRow(DestSh)
If sh.Name = "Sheet1" Then
Set CopyRng = sh.Range("A:G")
End If
If sh.Name = "Sheet2" Then
Set CopyRng = sh.Range("B:G")
End If
If sh.Name = "Sheet3" Then
Set CopyRng = sh.Range("C:G")
End If
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
Next
ExitTheSub:
Application.GoTo DestSh.Cells(1)
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Below is my Function
Option Explicit
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(what:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(what:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
Your source ranges are defined as Full Columns. Therefore you cannot paste them anywhere except somewhere at the first row of the destination sheet.
Remember that the number of rows in a worksheet is limited: 1048576 rows in Excel 2007 and later versions (65536 rows in Excel 2003). Therefore when you try to paste a full column somewhere not in the first row, the copy will exceed the last available row in the destination.
What you can do is take only the used part of the source columns, hoping that there is room for them in the destination sheet. To do this, change the way you define the source range, so that you take only the used part. i.e.:
Set CopyRng = sh.UsedRange.Columns("A:G")
' ^^^^^^^^^^^^^^^^^^^
Do the same for all the cases where you set the CopyRng.
Alternatively, you can find the last used row and last used column of the source worksheet the same way you are doing it for the destination worksheet. This option should be more accurate and safer.
I am trying to copy all worksheets, one at a time, and pasting into a new worksheet. These files come from multiple third parties so the worksheets can vary. I'm running into a problem below when trying to determine last row Lrow and last column Lcol because an error appears saying Object doesn't support this property or method. I do plan on submitting this to my work so any help with error proofing or general macro tips are appreciated.
Sub ws_copy()
Dim Lrow As Long
Dim Lcol As Long
Dim Pasterow As Long
Dim WSCount As Integer
Dim i As Integer
'On Error Resume Next
'Application.DisplayAlerts = False
i = Application.InputBox(prompt:="Enter the place order of first tab to be copied.", Title:="Worksheet Consolidation", Type:=1)
If IsEmpty(i) = True Then
Exit Sub
Else
If IsNumeric(i) = False Then
MsgBox "Enter a numeric value."
Else
If IsNumeric(i) = True Then
Worksheets.Add(before:=Sheets(1)).Name = "Upload"
WSCount = Worksheets.Count
For i = i + 1 To WSCount
Lrow = Worksheets(i).Find("*", After:=Cells(1, 1), _
LookIn:=xlFormulas, _
Lookat:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Lcol = Worksheets(i).Find("*", After:=Cells(1, 1), _
LookIn:=xlFormulas, _
Lookat:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Pasterow = Lrow + 1
Workbook.Worksheets(i).Range(Cells(1, 1), Cells(Lrow, Lcol)).Copy
Workbook.Worksheets("Upload").Cells(Pasterow, 1).Paste
Next i
Else
Exit Sub
End If
End If
End If
'On Error GoTo 0
'Application.DisplayAlerts = False
End Sub
A common way to find the last row/column is:
With Worksheets(i)
Lrow = .Cells(.Rows.Count, 1).End(xlUp).Row
Lcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
hth
Based on the comment that:
I can't assume any one column or row has the last piece of data because of the variety of the files received.
You should look at using the UsedRange property of the Worksheet (MSDN). UsedRange expands as more data is entered onto the worksheet.
Some people will avoid using UsedRange because if some data has been entered, and then deleted then UsedRange will include these 'empty' cells. The UsedRange will update itself when the workbook is saved. However, in your case, it doesn't sound like this is a relevant issue.
An example would be:
Sub Test()
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim rngSource As Range
Dim rngTarget As Range
Set wsSource = ThisWorkbook.Worksheets("Sheet1")
Set wsTarget = ThisWorkbook.Worksheets("Sheet2")
Set rngSource = wsSource.UsedRange
rngSource.Copy Destination:=wsTarget.Cells
End Sub
Here is a method of finding the last used row and last used column in a worksheet. It avoids the issues with UsedRange and also your issues of not knowing which row might have the last column (and which column might have the last row). Adapt to your purposes:
Option Explicit
Sub LastRowCol()
Dim LastRow As Long, LastCol As Long
With Worksheets("sheet1") 'or any sheet
If Application.WorksheetFunction.CountA(.Cells) > 0 Then
LastRow = .Cells.Find(what:="*", after:=[A1], _
LookIn:=xlFormulas, _
searchorder:=xlByRows, _
searchdirection:=xlPrevious).Row
LastCol = .Cells.Find(what:="*", after:=[A1], _
LookIn:=xlFormulas, _
searchorder:=xlByColumns, _
searchdirection:=xlPrevious).Column
Else
LastRow = 1
LastCol = 1
End If
End With
Debug.Print LastRow, LastCol
End Sub
Although the basic technique has been long used, Siddarth Rout, some time ago, posted a version adding COUNTA to account for the case where the worksheet might be empty -- a useful addition.
If you want to merge data on each sheet into one MasterSheet, run the script below.
Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
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"
'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
Last = LastRow(DestSh)
'Fill in the range that you want to copy
Set CopyRng = sh.Range("A1:G1")
'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 at the example below this macro
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name
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
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
Also, see the link below for some other options to do this slightly differently.
http://www.rondebruin.nl/win/s3/win002.htm
I have for the most part it working. I can't seem to get through the CopyRng block to set it for each sheet and gather the entire row where the cells are color filled. Set CopyRng = sh.Cells().Interior.Color = vbOrange sh.Cells().EntireRowCan anyone help?
Module1:
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
Module2:
Option Explicit
Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
Dim tbl As ListObject
Dim Cell As Range
Dim clrOrange As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
' Delete the summary sheet if it exists.
Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Worksheets("SummarySheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
' Add a new summary worksheet.
Set DestSh = ThisWorkbook.Worksheets.Add
DestSh.Name = "SummarySheet"
Range("A1").FormulaR1C1 = "=TODAY()"
Range("A3:G3").Font.Bold = True
Range("A3") = "Vendor"
Range("B3") = "Account#"
Range("C3") = "Job/Dept"
Range("D3") = "Cost Code/Account"
Range("E3") = "PO"
Range("F3") = "Bill Date"
Range("G3") = "Bill Date2"
clrOrange = RGB(255, 192, 0)
' Loop through all worksheets and copy the data to the
' summary worksheet.
For Each sh In ThisWorkbook.Worksheets
For Each tbl In sh.ListObjects
For Each Cell In tbl.DataBodyRange
If sh.Name <> DestSh.Name Then
' Find the last row with data on the summary worksheet.
Last = LastRow(DestSh)
' Specify the range to place the data. Select entire row where cells are orange.
If Cell.Interior.Color = clrOrange Then
If CopyRng Is Nothing Then
Set CopyRng = Cell
Else
Set CopyRng = Union(CopyRng, Cell)
End If
End If
' This statement copies values and formats from each
' worksheet.
Cell.EntireRow.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
End If
Next
Next
Next
ExitTheSub:
Application.GoTo DestSh.Cells(1)
' AutoFit the column width in the summary sheet.
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
You need to loop through the cells and check each to see if they are orange, then add them to CopyRng one by one:
Dim Cell as Range
For Each Cell in sh.Range("A1:A50") 'Or whatever the range is where orange cells can be
If Cell.Interior.Color = vbOrange Then
If CopyRng is Nothing then
Set CopyRng = Cell
Else
Set CopyRng = Union(CopyRng, Cell)
End If
EndIf
Next
CopyRng.Copy
etc.
I am trying to consolidate multiple worksheets in Excel into 1 worksheet. I use the consolidated worksheet to run a suite of reports in the same workbook.
The number of worksheets that need to be consolidated varies - approx 6 to 40 worksheets. I identify the sheets to be consolidated by prefixing them with "Src"
There are approx 40 other spreadsheets in the same workbook (reports that run off the consolidated worksheet and other calculations)
The format of each worksheet to be consolidated is the same
I am new to macros so have found some code on the internet to automate the consolidation but by the time I have 12 worksheets or so that need to be consolidated it runs very slowly.
Is there anyway that I am able to speed up this macro?
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
' Clear the consol worksheet except the top row with the headings
Set DestSh = ActiveWorkbook.Worksheets("All Data")
DestSh.Rows("5:" & Rows.Count).ClearContents
' Fill in the start row.ie the row in each of the source sheets that contain the data (do not include heading rows)
StartRow = 5
' Loop through all worksheets and copy the data to the
' summary worksheet if worksheet name starts with src.
For Each sh In ActiveWorkbook.Worksheets
If LCase(Left(sh.Name, 3)) = "src" Then
' Find the last row with data on the summary
' and source worksheets.
Last = LastRow(DestSh)
shLast = LastRow(sh)
' If source worksheet is not empty and if the last
' row >= StartRow, copy the range.
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 to see whether there are enough rows in the summary
' worksheet to copy all the data.
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the " & _
"summary worksheet to place the data."
GoTo ExitTheSub
End If
' This statement copies values, and formats.
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 summary sheet.
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
Under the assumption that you have one column where there is no blank row from start to end, try replacing the LastRow() function with
Function LastRow(sh As Worksheet)
Dim i as Long, R as Range
i = 1
Set R = sh.[A1]
Do while R(i,1) <> "" ' we asume column A (.. 1) here
i = i+1
Loop
LastRow = i
End Function
Alternatively you can play with the .CurrentRegion property to avoid counting rows & columns alltogether.
Replace:
Last = LastRow(DestSh)
shLast = LastRow(sh)
with
Last = DestSh.UsedRange.Rows.Count
shLast = sh.UsedRange.Rows.Count
You have a LastCol(sh) function, but I'm not actually seeing a call to it. If I'm missing it, you can replace the function call with:
sh.UsedRange.Columns.Count
Normally, a paste will copy both the values and the formatting, so unless there's something in particular you're trying to avoid, replace:
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
with
DestSh.Cells(Last + 1, "A").Paste
Application.CutCopyMode = False
Finally, remember that VBA code is interpreted as it executes and will inherently be slower than pre-compiled code. Also, it's still significantly quicker than doing it by hand!