Loop through worksheets take last line add to summary tab

[CLCoop]

1) Loop through unknown amount of tabs. Take the last row containing data from each worksheet move to the top of each worksheet
2) Look through unknown amount of tabs. Take last row from each tab and input in same order on a summary tab.
Unknown number of tabs as I want to build this to support several different spreadsheets that are done regularly all having anywhere from 2 to 48 tabs with different names.

Basically I'm trying to make a summary sheet of what is in the workbook based.
Right now I have it set up using VBA to build a summary sheet that hyperlinks to each worksheet. But I'm wanting the TOTAL (field name) that could be anywhere in the many different tabs but most always is on the last row to be moved to the top row and to show on the summary page.

 

[Ron de Bruin]

Copy macro and function in a module of your test workbook


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)

'Code to copy last row to row 1 after it insert one row
sh.Rows(1).Insert
last2 = LastRow(sh)
sh.Rows(last2).Cut sh.Rows(1)

'Fill in the range that you want to copy in the first row
Set CopyRng = sh.Range("A1:Z1")

'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

 

[Ron de Bruin]

Change this line to a column after Z in my example below
'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name