Merging tables and arrays from multiple sheets into one consolidated table - arrays

Question

I am very new to VBA and struggling!
I've tried searching the forums but can't find anything close enough to my situation...
I have 30+ sheets titled 001, 002 ...0nn
I want to create a new sheet title 'Actions summary'
I want this sheet to contain compiled information from each sheet with sheet name '0nn' (or i tried limiting the code to sheet names that are integers) - -
From each sheet i want to copy the information from columns A to G, And rows 9 to last row with information in.
I would also like the heading (A8:G8) at the top of the new 'actions summary' sheet.
SCREEN SHOT typical sheet 0nn format
Been going a bit mad and would really appreciate some simple help, ideally the code required with explanations for what each bit is doing so i can learn.
My Attempt below:
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 DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
' Delete the summary sheet if it exists.
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Actions Summary").Delete
On Error GoTo 0
Application.DisplayAlerts = True
' Add a new summary worksheet.
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Actions Summary"
' Loop through all worksheets and copy the data to the
' summary worksheet.
For Each sh In ActiveWorkbook.Worksheets
'If LCase(Left(sh.Name, 1)) = "0" Then
If IsNumeric(sh.Name) = True Then
Debug.Print (sh.Name)
' Find the last row with data on the summary worksheet.
Last = LastRow(DestSh)
'LastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
Debug.Print (Last)
' Specify the range to place the data.
Set CopyRng = sh.Range("A9").CurrentRegion
Set CopyRng = Range(Cells(9, 1), Cells(Last, 7))
' 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 from each
' worksheet.
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
' Optional: This statement 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 summary sheet.
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Sub selectA1_and_insertRow()
'
' selectA1_and_insertRow Macro
Worksheets("Actions Summary").Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("B:B").ColumnWidth = 36.43
Rows("1:1").Select
'Range.Copy to other worksheets
Worksheets("001").Range("A8:G8").Copy Worksheets("Actions Summary").Range("A1:G1")
End Sub
Many thanks in advance.
Tom
CODE:
Here's the new code:
Sub UpDate_List_v2()
Dim wb As Workbook
Dim ws As Worksheet
Dim wsSum As Worksheet
Dim rLastCell As Range
Dim lCalc As XlCalculation
Dim bHasHeaders As Boolean
'Turn off calculation, events, and screenupdating
'This allows the code to run faster and prevents "screen flickering"
With Application
lCalc = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
Set wb = ActiveWorkbook
'Check if Actions Summary sheet exists already or not
On Error Resume Next
Set wsSum = wb.Sheets("Actions summary")
On Error GoTo 0
If wsSum Is Nothing Then
'Does not exist, create it
Set wsSum = wb.Sheets.Add(Before:=wb.Sheets(1))
wsSum.Name = "Actions summary"
bHasHeaders = False
Else
'Already exists, clear previous data
wsSum.UsedRange.Offset(1).Clear
bHasHeaders = True
End If
'Loop through all sheets in the workbook
For Each ws In wb.Sheets
'Only look for worksheets whose names are numbers (e.g. "001", "002", etc)
If IsNumeric(ws.Name) Then
'Check if the "Actions Summary" sheet already has headers
If bHasHeaders = False Then
'Does not have headers yet
With ws.Range("A8:M8")
'Check if this sheet has headers in A8:G8
If WorksheetFunction.CountBlank(.Cells) = 0 Then
'This sheet does have headers, copy them over
.Copy wsSum.Range("A1")
bHasHeaders = True
End If
End With
End If
'Find the last row of the sheet
Set rLastCell = ws.Cells.Find("*", ws.Range("A1"), SearchDirection:=xlPrevious)
If Not rLastCell Is Nothing Then
'Check if the last row is greater than the header row
If rLastCell.Row > 8 Then
'Last row is greater than the header row so there is data
'Check if the "Actions Summary" sheet has enough rows to hold the data
If wsSum.Cells(wsSum.Rows.Count, "A").End(xlUp).Row + rLastCell.Row - 8 > wsSum.Rows.Count Then
'Not enough rows, return error and exit the subroutine
MsgBox "There are not enough rows in the summary worksheet to place the data.", , "Data Overflow"
Exit Sub
Else
'Does have enough rows, copy the data - Values
ws.Range("A9:M" & rLastCell.Row).Copy
With wsSum.Cells(wsSum.Rows.Count, "A").End(xlUp).Offset(1)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
End If
End If
End If
End If
Next ws
'Sheets("Actions summary").Columns("H:L").EntireColumn.Delete 'Delete unwanted columns
'Sheets("Actions summary").Columns("H:L").Hidden = True 'Hide unwanted columns
Worksheets("Actions summary").Columns("H:j").Hidden = True
Worksheets("Actions summary").Columns("L").Hidden = True
Sheets("Actions summary").Columns("H").Style = "currency" 'Set to £
Application.CutCopyMode = False 'Remove the cut/copy border
'wsSum.Range("A1").CurrentRegion.EntireColumn.AutoFit 'Autofit columns on the "Actions Summary" sheet
'Turn calculation, events, and screenupdating back on
With Application
.Calculation = lCalc
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

Answer 1

Something like this should work for you. I have commented the code for clarity.
Sub tgr()
Dim wb As Workbook
Dim ws As Worksheet
Dim wsSum As Worksheet
Dim rLastCell As Range
Dim lCalc As XlCalculation
Dim bHasHeaders As Boolean
'Turn off calculation, events, and screenupdating
'This allows the code to run faster and prevents "screen flickering"
With Application
lCalc = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
Set wb = ActiveWorkbook
'Check if Actions Summary sheet exists already or not
On Error Resume Next
Set wsSum = wb.Sheets("Actions summary")
On Error GoTo 0
If wsSum Is Nothing Then
'Does not exist, create it
Set wsSum = wb.Sheets.Add(Before:=wb.Sheets(1))
wsSum.Name = "Actions summary"
bHasHeaders = False
Else
'Already exists, clear previous data
wsSum.UsedRange.Offset(1).Clear
bHasHeaders = True
End If
'Loop through all sheets in the workbook
For Each ws In wb.Sheets
'Only look for worksheets whose names are numbers (e.g. "001", "002", etc)
If IsNumeric(ws.Name) Then
'Check if the "Actions Summary" sheet already has headers
If bHasHeaders = False Then
'Does not have headers yet
With ws.Range("A8:G8")
'Check if this sheet has headers in A8:G8
If WorksheetFunction.CountBlank(.Cells) = 0 Then
'This sheet does have headers, copy them over
.Copy wsSum.Range("A1")
bHasHeaders = True
End If
End With
End If
'Find the last row of the sheet
Set rLastCell = ws.Cells.Find("*", ws.Range("A1"), SearchDirection:=xlPrevious)
If Not rLastCell Is Nothing Then
'Check if the last row is greater than the header row
If rLastCell.Row > 8 Then
'Last row is greater than the header row so there is data
'Check if the "Actions Summary" sheet has enough rows to hold the data
If wsSum.Cells(wsSum.Rows.Count, "A").End(xlUp).Row + rLastCell.Row - 8 > wsSum.Rows.Count Then
'Not enough rows, return error and exit the subroutine
MsgBox "There are not enough rows in the summary worksheet to place the data.", , "Data Overflow"
Exit Sub
Else
'Does have enough rows, copy the data - Values
ws.Range("A9:G" & rLastCell.Row).Copy
With wsSum.Cells(wsSum.Rows.Count, "A").End(xlUp).Offset(1)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
End If
End If
End If
End If
Next ws
Application.CutCopyMode = False 'Remove the cut/copy border
wsSum.Range("A1").CurrentRegion.EntireColumn.AutoFit 'Autofit columns on the "Actions Summary" sheet
'Turn calculation, events, and screenupdating back on
With Application
.Calculation = lCalc
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub