Create Table From Specific Range in Multiple Worksheets

jski21

Board Regular
Joined
Jan 2, 2019
Messages
67
Office Version
  1. 2016
Platform
  1. Windows
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

Board Regular
Joined
Jan 2, 2019
Messages
67
Office Version
  1. 2016
Platform
  1. Windows
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
 

Excel Facts

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off

jski21

Board Regular
Joined
Jan 2, 2019
Messages
67
Office Version
  1. 2016
Platform
  1. Windows
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

Well-known Member
Joined
Oct 18, 2011
Messages
688
Office Version
  1. 365
Platform
  1. Windows
ok some more tweaks, please test the code below

VBA Code:
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

Board Regular
Joined
Jan 2, 2019
Messages
67
Office Version
  1. 2016
Platform
  1. Windows
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

Well-known Member
Joined
Oct 18, 2011
Messages
688
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

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

VBA Code:
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
 
Solution

Crystalyzer

Well-known Member
Joined
Oct 18, 2011
Messages
688
Office Version
  1. 365
Platform
  1. Windows
LOL you marked your post as the solution. :)
 

jski21

Board Regular
Joined
Jan 2, 2019
Messages
67
Office Version
  1. 2016
Platform
  1. Windows
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.
 

Forum statistics

Threads
1,148,422
Messages
5,746,589
Members
424,032
Latest member
pochie2741

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top