Create Table From Specific Range in Multiple Worksheets

jski21

Board Regular
Joined
Jan 2, 2019
Messages
65
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.
 

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.

Crystalyzer

Well-known Member
Joined
Oct 18, 2011
Messages
688
Office Version
  1. 365
Platform
  1. Windows
Some minor tweeks but this works with my test workbook

VBA Code:
Sub Merge_Sheets()

    Dim startRow As Long, startCol As Long, lastRow As Long, lastCol As Long
    Dim headers As Range
    Dim mtr As Worksheet
    Dim wb As Workbook
    
    '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
    With ws
    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 With
    End If
    Next ws
    
    Worksheets("Master").Activate

End Sub
 

jski21

Board Regular
Joined
Jan 2, 2019
Messages
65
Office Version
  1. 2016
Platform
  1. Windows
Thanks Crystalyzer. I'm getting a crazy 400 error on this. The headings transfer in to the Master sheet then it stops. All 17 sheets look like this:

Test.xlsm
ABCDEFGHIJKLMNO
1
2
3
4
5
6
7Column 1Column 2Column 3Column 4Column 5Column 6Column 7Column 8Column 9Column 10Column 11Column 12Column 13
8Budget
975,000.00
10YR 47 Start Balance626,881.34
11Yr 43 - 14047700(51,498.96)14043810Project 1 Item 1CDC250,000.001404770032,000.00250,000.006/1/2021282,000.005/20/2021W1
12Yr 45 - 14047700(38,501.04)14045810 
13Yr 46 - 14047700(25,397.34)14046810 
14Yr 47 - 14047700(134,602.66)14047700 
15YR46 - Project 1 Item 2 W1
16 
17 
18 
19 
20 
21Total Balance376,881.3475,000.00
1
Cell Formulas
RangeFormula
B10B10=SUM(R1:R8)
L11:L20L11=IF(J11+I11=0,"",J11+I11)
B21B21=SUM(B10:C20)
C21C21=SUM(C9:C20)


Just seeking to capture Columns 2 - 13 in all the sheets and placed in a table in the Master sheet.
 

Crystalyzer

Well-known Member
Joined
Oct 18, 2011
Messages
688
Office Version
  1. 365
Platform
  1. Windows
Thanks for the example worksheet. It highlighted a bunch that you neglected to mention in your original request. Like merged cells and formulas. In the future, it would be best to start out with that.

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, j 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)
   
    'Copy Headers into master
    headers.Copy mtr.Range("A1")
    startRow = headers.Row + 4
    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
            With ws
                lastCol = .Cells(startRow - 4, Columns.Count).End(xlToLeft).Column
                ReDim arr(lastCol - 1)
                For i = 0 To lastCol - 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 mtr.Cells(Rows.Count, 1).End(xlUp).Row + 1 = 2 Then
                    mstStrRow = mtr.Cells(Rows.Count, j).End(xlUp).Row + 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
            End With
        End If
    Next ws
   
    Worksheets("Master").Activate
 

jski21

Board Regular
Joined
Jan 2, 2019
Messages
65
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

Thanks. It captured the info in Sheet 1 then a 400 error. Something on my end perhaps?
 

Crystalyzer

Well-known Member
Joined
Oct 18, 2011
Messages
688
Office Version
  1. 365
Platform
  1. Windows
Must be, I copied your worksheet example to create it. What's different from the example to your actual data?
 

jski21

Board Regular
Joined
Jan 2, 2019
Messages
65
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

Not much...deleted data in the large merged cell A1 for the XL2BB file. All the sheets have data in this field. The only other data is in the rightmost Columns of P-Z but not concerned about grabbing that. That applies to all the sheets as well.
 

Crystalyzer

Well-known Member
Joined
Oct 18, 2011
Messages
688
Office Version
  1. 365
Platform
  1. Windows
please post an XL2BB of ALL columns and data
 

jski21

Board Regular
Joined
Jan 2, 2019
Messages
65
Office Version
  1. 2016
Platform
  1. Windows
Test.xlsm
ABCDEFGHIJKLMNOQRSTUVWXYZ
1ABCDEYr 40-
2Yr 41-
3Yr 42-
4Yr 43-
5Yr 44-
6Yr 45-15,000.00(15,000.00)
7Column 1Column 2Column 3Column 4Column 5Column 6Column 7Column 8Column 9Column 10Column 11Column 12Column 13Yr 46269,186.30(15,000.00)(115,000.00)(5,000.00)(134,186.30)
8BudgetYr 47435,294.00(150,813.70)
9From Yr 46269,186.3073,500.00
10
11YR 47 Start Balance704,480.30
12YR4515,000.00SWAPProject 15 Item 1SWAP15,000.0015,000.005/20/202115,000.005/20/2021W15
13YR 46(15,000.00)SWAPProject 15 Item 2SWAP(15,000.00)(15,000.00)5/20/2021(15,000.00)5/20/2021W15
14YR 45 - 14047705(15,000.00)14045815Project 15 Item 3CDC130,000.001404770540,000.00130,000.006/3/2021170,000.005/10/2021W15
15YR 46 - 14047705(115,000.00)14047705
16YR 46 - 14047733(5,000.00)14047733Project 15 Item 4CDC5,000.001404773351,300.00200,000.006/3/2021251,300.005/29/2021Ward 3W15
17YR 46 - 14047707(134,186.30)14046806Project 15 Item 5CDC285,000.001404770781,500.00285,000.006/9/2021366,500.005/11/2021W15
18YR 47 - 14047707(150,813.70)14047707
19
20
21Total Balance284,480.3073,500.00
15
Cell Formulas
RangeFormula
B9B9=SUM(R6:S7)
B11B11=SUM(R1:R8)
L16:L17,L12:L14L12=IF(J12+I12=0,"",J12+I12)
B21B21=SUM(B11:C20)
C21C21=SUM(C9:C20)



Does this help?
 

Crystalyzer

Well-known Member
Joined
Oct 18, 2011
Messages
688
Office Version
  1. 365
Platform
  1. Windows
The problem was the data in columns Q-V in row 7 which was causing the lastcol number to be calculated incorrectly. I adjusted for this so no need to change anything. Now the lastcol will caculate from the headers that are selected.

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
    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)
    
    'Copy Headers into master
    headers.Copy mtr.Range("A1")
    startRow = headers.Row + 4
    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
            With ws
                'lastCol = .Cells(startRow - 4, Columns.Count).End(xlToLeft).Column
                lastCol = headers.Columns.Count + headers.Column - 1
                ReDim arr(lastCol - 1)
                For i = 0 To lastCol - 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 mtr.Cells(Rows.Count, 1).End(xlUp).Row + 1 = 2 Then
                    mstStrRow = mtr.Cells(Rows.Count, j).End(xlUp).Row + 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
            End With
        End If
    Next ws
    
    Worksheets("Master").Activate

End Sub
 

Forum statistics

Threads
1,148,172
Messages
5,745,176
Members
423,931
Latest member
thangvan114

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