Create Table From Specific Range in Multiple Worksheets

[jski21]

Good day Mr. Excel Team,

Seeking to combine specific range of data from 17 different worksheets into a single table in a new worksheet. Header row is D7:O7 across all sheets, and range for extraction would be 100 rows down (might change as time goes on) from the header row.

Using the code below with some difficulty:


Sub Merge_Sheets()

Dim startRow, startCol, lastRow, lastCol As Long
Dim headers As Range

'Set Master sheet for consolidation
Set mtr = Worksheets("Master")

Set wb = ThisWorkbook
'Get Headers
Set headers = Application.InputBox("Select the Headers", Type:=8)

'Copy Headers into master
headers.Copy mtr.Range("A1")
startRow = headers.Row + 1
startCol = headers.Column

Debug.Print startRow, startCol
'loop through all sheets
For Each ws In wb.Worksheets
'except the master sheet from looping
If ws.Name <> "Master" And ws.Name <> "Tables" And ws.Name <> "NDAForm" And ws.Name <> "BudgetAdj" And ws.Name <> "NDA Summary" _
Then
ws.Activate
lastRow = Cells(Rows.Count, startCol).End(xlUp).Row
lastCol = Cells(startRow, Columns.Count).End(xlToLeft).Column
'get data from each worksheet and copy it into Master sheet
Range(Cells(startRow, startCol), Cells(lastRow, lastCol)).Copy _
mtr.Range("A" & mtr.Cells(Rows.Count, 1).End(xlUp).Row + 1)
End If
Next ws

Worksheets("Master").Activate

End Sub


Any assistance would be most appreciated. Thanks.

 

[jski21]

Thanks. Getting a PasteSpecial method of Range class failed error (1004) right after the first sheet is drawn in:

'get data from each worksheet and copy it into Master sheet
.Range(.Cells(startRow, startCol), .Cells(lastRow, lastCol)).Copy
mtr.Range("A" & mstStrRow).PasteSpecial xlPasteValues

 

[jski21]

Thanks. Getting a "PasteSpecial method of Range class failed" (1004) error right after the first page is drawn in:

'get data from each worksheet and copy it into Master sheet
.Range(.Cells(startRow, startCol), .Cells(lastRow, lastCol)).Copy
mtr.Range("A" & mstStrRow).PasteSpecial xlPasteValues

 

[Crystalyzer]

ok some more tweaks, please test the code below

Sub Merge_Sheets()

    Dim startRow As Long, startCol As Long, lastRow As Long
    Dim lastCol As Long, mstStrRow As Long, i As Long, noCopyCols As Long
    Dim headers As Range
    Dim mtr As Worksheet
    Dim wb As Workbook
    Dim arr() As Variant
    
    
    'Set Master sheet for consolidation
    Set mtr = Worksheets("Master")
    
    Set wb = ThisWorkbook
    'Get Headers
    Set headers = Application.InputBox("Select the Headers", Type:=8)
    
    Application.ScreenUpdating = False
    'Copy Headers into master
    headers.Copy mtr.Range("A1")
    startRow = headers.Row + 4
    startCol = headers.Column
    lastCol = headers.Columns.Count + headers.Column - 1
    noCopyCols = headers.Columns.Count
    
    'loop through all sheets
    For Each ws In wb.Worksheets
        If ws.Name <> "Master" And ws.Name <> "Tables" And ws.Name <> "NDAForm" _
            And ws.Name <> "BudgetAdj" And ws.Name <> "NDA Summary" Then
            With ws
                ReDim arr(noCopyCols - 1)
                For i = 0 To noCopyCols - 1
                    arr(i) = .Cells(Rows.Count, startCol + i).End(xlUp).Row
                    If i = 0 Then
                        j = i + 1
                    Else
                        If arr(i) > arr(i - 1) Then j = i + 1
                    End If
                Next i
                lastRow = WorksheetFunction.Max(arr)
                mstStrRow = 0
                mstStrRow = mtr.Cells(Rows.Count, j).End(xlUp).Row
                If mstStrRow = 1 Then
                    mstStrRow = mstStrRow + 2
                Else
                    mstStrRow = mtr.Cells(Rows.Count, j).End(xlUp).Row + 1
                End If
                'get data from each worksheet and copy it into Master sheet
                .Range(.Cells(startRow, startCol), .Cells(lastRow, lastCol)).Copy
                mtr.Range("A" & mstStrRow).PasteSpecial xlPasteValues
                mtr.Range("A" & mstStrRow).PasteSpecial xlPasteFormats
            End With
        End If
    Next ws
    
    Worksheets("Master").Activate
    Range("A1").Select
    Application.ScreenUpdating = True
End Sub

 

[jski21]

Ok...same error came about and I took a closer look at the output, code, and sheets. Second sheet has no entries (yet) which was causing this to hang up after Sheet 1. Entered "xxx" in one field on Sheet 2 and it rolled through them all with predictable results. Thanks for sticking with me Crystalyzer. It was not only helpful, but very instructive as well. Sincerely appreciate your consideration and assistance on this one. With your help and expertise, I'll be able to modify/apply this across a few other workbooks as well.

 

[Crystalyzer]

Adjusted the code to skip blank worksheets so no need to enter dummy data

Sub Merge_Sheets()

    Dim startRow As Long, startCol As Long, lastRow As Long
    Dim lastCol As Long, mstStrRow As Long, i As Long, noCopyCols As Long
    Dim headers As Range
    Dim mtr As Worksheet
    Dim wb As Workbook
    Dim arr() As Variant
    
    
    'Set Master sheet for consolidation
    Set mtr = Worksheets("Master")
    
    Set wb = ThisWorkbook
    'Get Headers
    Set headers = Application.InputBox("Select the Headers", Type:=8)
    
    Application.ScreenUpdating = False
    'Copy Headers into master
    headers.Copy mtr.Range("A1")
    startRow = headers.Row + 4
    startCol = headers.Column
    lastCol = headers.Columns.Count + headers.Column - 1
    noCopyCols = headers.Columns.Count
    
    'loop through all sheets
    For Each ws In wb.Worksheets
        If ws.Name <> "Master" And ws.Name <> "Tables" And ws.Name <> "NDAForm" _
            And ws.Name <> "BudgetAdj" And ws.Name <> "NDA Summary" Then
            With ws
                ReDim arr(noCopyCols - 1)
                For i = 0 To noCopyCols - 1
                    arr(i) = .Cells(Rows.Count, startCol + i).End(xlUp).Row
                    If i = 0 Then
                        j = i + 1
                    Else
                        If arr(i) > arr(i - 1) Then j = i + 1
                    End If
                Next i
                lastRow = WorksheetFunction.Max(arr)
                If lastRow < 11 Then GoTo SkipWS
                mstStrRow = 0
                mstStrRow = mtr.Cells(Rows.Count, j).End(xlUp).Row
                If mstStrRow = 1 Then
                    mstStrRow = mstStrRow + 2
                Else
                    mstStrRow = mtr.Cells(Rows.Count, j).End(xlUp).Row + 1
                End If
                'get data from each worksheet and copy it into Master sheet
                .Range(.Cells(startRow, startCol), .Cells(lastRow, lastCol)).Copy
                mtr.Range("A" & mstStrRow).PasteSpecial xlPasteValues
                mtr.Range("A" & mstStrRow).PasteSpecial xlPasteFormats
            End With
        End If
SkipWS:
    Next ws
    
    Worksheets("Master").Activate
    Range("A1").Select
    Application.ScreenUpdating = True
End Sub

 

[Crystalyzer]

LOL you marked your post as the solution.

 

[jski21]

Sorry...yes, clicked the wrong post. To all those referencing this thread in the future, Crystalyzer is the man! All kudos and props to him.