The code is posted below. Also see the attachment.
Option Explicit
Sub ConsolidateMyData()
'===================================================================
'Declare Variables
'===================================================================
Dim LastRow As Integer 'Used to find the last row used on the Summary tab
Dim SummaryTab As String 'Used to define which tab to return to at the end
Dim ws As Worksheet ' Used to loop through the worksheets
'===================================================================
'Define Variables
'===================================================================
SummaryTab = ThisWorkbook.Worksheets("Summary").Name 'Defines the tab name
LastRow = ThisWorkbook.Worksheets("Summary").Cells(Rows.Count, 1).End(xlUp).Row + 1 ' Finds the FIRST unused row on the Summary tab
'===================================================================
'Setup For Speed
'===================================================================
Application.ScreenUpdating = False 'turns off Screen Updating
Application.Calculation = xlCalculationManual 'turns off Calculations
'===================================================================
'Clear Data tab before begining
'===================================================================
ThisWorkbook.Sheets(SummaryTab).Activate
ThisWorkbook.Sheets(SummaryTab).Range("A2:D1048576").Clear 'Simply clears the Data tab except for the headers
'===================================================================
'Copy and Paste
'===================================================================
For Each ws In Worksheets
If ws.Name <> SummaryTab Then
Application.StatusBar = "Aggregating worksheet: " & ws.Name
ws.Activate
LastRow = ThisWorkbook.Worksheets(SummaryTab).Cells(Rows.Count, 1).End(xlUp).Row + 1 ' Calculates the first open row on the data tab
ThisWorkbook.Worksheets(SummaryTab).Range("A" & LastRow).Value = ws.Name
ThisWorkbook.Worksheets(SummaryTab).Range("B" & LastRow).Value = Sheets(ws.Name).Range("H29").Value
ThisWorkbook.Worksheets(SummaryTab).Range("C" & LastRow).Value = Sheets(ws.Name).Range("H30").Value
ThisWorkbook.Worksheets(SummaryTab).Range("D" & LastRow).Value = Sheets(ws.Name).Range("H31").Value
End If
Next ws
'===================================================================
'End Macro Procedures
'===================================================================
ThisWorkbook.Sheets(SummaryTab).Activate 'Returns to the SummaryTab
Application.StatusBar = False 'Clears the Statusbar
Application.ScreenUpdating = True 'turns screen updating back on
Application.Calculation = xlCalculationAutomatic ' turns calculations back on
ThisWorkbook.RefreshAll 'Refreshes all pivot tables
MsgBox "Data Consolidation Complete" 'offers a message box
End Sub
ConsolidateDataToOneTab.xlsm
Bookmarks