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.

 

[Crystalyzer]

Some minor tweeks but this works with my test workbook

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]

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
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
1
2
3
4
5
6
7			Column 1	Column 2	Column 3	Column 4	Column 5	Column 6	Column 7	Column 8	Column 9	Column 10	Column 11	Column 12	Column 13
8		Budget
9			75,000.00
10	YR 47 Start Balance	626,881.34
11	Yr 43 - 14047700	(51,498.96)		14043810	Project 1 Item 1	CDC	250,000.00	14047700	32,000.00	250,000.00	6/1/2021	282,000.00	5/20/2021		W1
12	Yr 45 - 14047700	(38,501.04)		14045810
13	Yr 46 - 14047700	(25,397.34)		14046810
14	Yr 47 - 14047700	(134,602.66)		14047700
15	YR46 -				Project 1 Item 2										W1
16
17
18
19
20
21	Total Balance	376,881.34	75,000.00
1

Cell Formulas
Range	Formula
B10	B10	=SUM(R1:R8)
L11:L20	L11	=IF(J11+I11=0,"",J11+I11)
B21	B21	=SUM(B10:C20)
C21	C21	=SUM(C9:C20)

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

 

[Crystalyzer]

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.

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]

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

 

[Crystalyzer]

Must be, I copied your worksheet example to create it. What's different from the example to your actual data?

 

[jski21]

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]

please post an XL2BB of ALL columns and data

 

[jski21]

Test.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O		Q	R	S	T	U	V	W	X	Y	Z
1	ABCDE																Yr 40	-
2																	Yr 41	-
3																	Yr 42	-
4																	Yr 43	-
5																	Yr 44	-
6																	Yr 45	-	15,000.00	(15,000.00)
7			Column 1	Column 2	Column 3	Column 4	Column 5	Column 6	Column 7	Column 8	Column 9	Column 10	Column 11	Column 12	Column 13		Yr 46	269,186.30	(15,000.00)	(115,000.00)	(5,000.00)	(134,186.30)
8		Budget															Yr 47	435,294.00	(150,813.70)
9	From Yr 46	269,186.30	73,500.00
10
11	YR 47 Start Balance	704,480.30
12	YR45	15,000.00		SWAP	Project 15 Item 1	SWAP	15,000.00			15,000.00	5/20/2021	15,000.00	5/20/2021		W15
13	YR 46	(15,000.00)		SWAP	Project 15 Item 2	SWAP	(15,000.00)			(15,000.00)	5/20/2021	(15,000.00)	5/20/2021		W15
14	YR 45 - 14047705	(15,000.00)		14045815	Project 15 Item 3	CDC	130,000.00	14047705	40,000.00	130,000.00	6/3/2021	170,000.00	5/10/2021		W15
15	YR 46 - 14047705	(115,000.00)		14047705
16	YR 46 - 14047733	(5,000.00)		14047733	Project 15 Item 4	CDC	5,000.00	14047733	51,300.00	200,000.00	6/3/2021	251,300.00	5/29/2021	Ward 3	W15
17	YR 46 - 14047707	(134,186.30)		14046806	Project 15 Item 5	CDC	285,000.00	14047707	81,500.00	285,000.00	6/9/2021	366,500.00	5/11/2021		W15
18	YR 47 - 14047707	(150,813.70)		14047707
19
20
21	Total Balance	284,480.30	73,500.00
15

Cell Formulas
Range	Formula
B9	B9	=SUM(R6:S7)
B11	B11	=SUM(R1:R8)
L16:L17,L12:L14	L12	=IF(J12+I12=0,"",J12+I12)
B21	B21	=SUM(B11:C20)
C21	C21	=SUM(C9:C20)

Does this help?

 

[Crystalyzer]

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.

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