Is there a faster way to perform this VBA macro? - vba

Question

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

Answer 1

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.

Answer 2

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!