Hi everyone,
I'm trying to create a summary sheet that captures data in cells M2:T55 in each worksheet and summarizes it to a sheet called "Defaults". The code is working correctly but it captures empty cells too and I'm stumped on how to prevent copying empty cells/rows. Appreciate any help offered; code appears below.
Sub SummarizeDefaults()
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 "Defaults" if it exist
'Application.DisplayAlerts = False
'On Error Resume Next
'ActiveWorkbook.Worksheets("Defaults").Delete
'On Error GoTo 0
'Application.DisplayAlerts = True
'Add a worksheet with the name "Defauts"
'Set DestSh = ActiveWorkbook.Worksheets.Add
'DestSh.Name = "Defaults"
'Updates current "Defaults" sheet, does not create new sheet
Set Basebook = ThisWorkbook
Set DestSh = Basebook.Worksheets("Defaults")
DestSh.Rows("2:" & DestSh.Rows.Count).Clear
'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
'Copy header row, change the range if you use more columns
If WorksheetFunction.CountA(DestSh.UsedRange) = 0 Then sh.Range("m1:t1").Copy DestSh.Range("A1")
'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("m2:t55")
'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 copies values/formats
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 I column
'DestSh.Cells(Last + 1, "I").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
I'm trying to create a summary sheet that captures data in cells M2:T55 in each worksheet and summarizes it to a sheet called "Defaults". The code is working correctly but it captures empty cells too and I'm stumped on how to prevent copying empty cells/rows. Appreciate any help offered; code appears below.
Sub SummarizeDefaults()
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 "Defaults" if it exist
'Application.DisplayAlerts = False
'On Error Resume Next
'ActiveWorkbook.Worksheets("Defaults").Delete
'On Error GoTo 0
'Application.DisplayAlerts = True
'Add a worksheet with the name "Defauts"
'Set DestSh = ActiveWorkbook.Worksheets.Add
'DestSh.Name = "Defaults"
'Updates current "Defaults" sheet, does not create new sheet
Set Basebook = ThisWorkbook
Set DestSh = Basebook.Worksheets("Defaults")
DestSh.Rows("2:" & DestSh.Rows.Count).Clear
'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
'Copy header row, change the range if you use more columns
If WorksheetFunction.CountA(DestSh.UsedRange) = 0 Then sh.Range("m1:t1").Copy DestSh.Range("A1")
'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("m2:t55")
'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 copies values/formats
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 I column
'DestSh.Cells(Last + 1, "I").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