jski21
Board Regular
- Joined
- Jan 2, 2019
- Messages
- 155
- Office Version
- 2016
- Platform
- Windows
Good day Mr. Excel Team,
I was using the code below successfully to produce a table from 17 different tabs and it just stopped working for some odd reason:
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
Sheets.Add(After:=Sheets("17")).Name = "Master"
Set mtr = Worksheets("Master")
Set wb = ThisWorkbook
'Get Headers
Worksheets("1").Activate
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 <> "NDAForm (2)" And ws.Name <> "Ordinances" _
And ws.Name <> "BudgetAdj" And ws.Name <> "NDA Summary" _
And ws.Name <> "Pivot" And ws.Name <> "Charts" 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
'Format the data
'Range("A1:L2").Select
Range("A1:N2").Select
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
Selection.UnMerge
'Range("A1:L1").Select
Range("A1:N1").Select
Selection.Font.Underline = xlUnderlineStyleSingle
Selection.Font.Bold = True
'Columns("A:L").Select
Columns("A:N").Select
'Columns("A:L").EntireColumn.AutoFit
Columns("A:N").EntireColumn.AutoFit
'Range("A1:L1").Select
Range("A1:N1").Select
Selection.AutoFilter
'Columns("A:L").Select
Columns("A:N").Select
'Columns("A:L").EntireColumn.AutoFit
Columns("A:N").EntireColumn.AutoFit
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
Range("A1").Select
Cells.Select
With Selection
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.UnMerge
'Deletes entire row if cell in Colum L is blank (get rid of dupe entries and blank rows)
Application.ScreenUpdating = False
Columns("L:L").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
'Create Columns for Month Number and for Fiscal Year
Range("M1").Select
ActiveCell.Value = "StartMnth"
Range("M2").Select
ActiveCell.Value = "6"
'Range("M3").Select
'Range("A1").Select
Range("N1").Select
ActiveCell.Value = "Fiscal Year"
Range("N2").Select
ActiveCell.Formula = "=YEAR(J2+(MONTH(J2)>=M2))"
'Range("N3").Select
'Range("A1").Select
'Autofill down Date Formula in M2 to end of data table
Range("M2").AutoFill Range("M2:M" & Range("A" & Rows.Count).End(xlUp).Row)
Range("N2").AutoFill Range("N2:N" & Range("A" & Rows.Count).End(xlUp).Row)
'Format Data and change it to a Table
Cells.Select
With Selection.Font
.Name = "Calibri"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
With Selection.Font
.Name = "Calibri"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Columns("A:N").Select
Columns("A:N").EntireColumn.AutoFit
ActiveWindow.SmallScroll ToRight:=-2
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A:$N"), , xlYes).Name = "Table1"
Columns("A:N").Select
ActiveSheet.ListObjects("Table1").TableStyle = "TableStyleLight1"
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
ActiveWindow.Zoom = 90
'Format Numbers
Range("D:D,G:G,I:I,F:F").Select
Range("Table1[[#Headers],[Departmental Funds]]").Activate
Selection.NumberFormat = "#,##0.00 ;[Red](#,##0.00);- ;"
Range("D1,F1,G1,I1").Select
Range("Table1[[#Headers],[PIF Amount]]").Activate
Selection.NumberFormat = "General"
Range("A1").Select
End Sub
The successful result looks like this:
This accurate resulting table is actually about 650+ lines.
It now looks like this:
I've walked through the code (F8) and can't quite figure out the disconnect. Doesn't seem to be capturing/pasting the data in.
Thanks in advance for the review and guidance.
jski
I was using the code below successfully to produce a table from 17 different tabs and it just stopped working for some odd reason:
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
Sheets.Add(After:=Sheets("17")).Name = "Master"
Set mtr = Worksheets("Master")
Set wb = ThisWorkbook
'Get Headers
Worksheets("1").Activate
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 <> "NDAForm (2)" And ws.Name <> "Ordinances" _
And ws.Name <> "BudgetAdj" And ws.Name <> "NDA Summary" _
And ws.Name <> "Pivot" And ws.Name <> "Charts" 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
'Format the data
'Range("A1:L2").Select
Range("A1:N2").Select
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
Selection.UnMerge
'Range("A1:L1").Select
Range("A1:N1").Select
Selection.Font.Underline = xlUnderlineStyleSingle
Selection.Font.Bold = True
'Columns("A:L").Select
Columns("A:N").Select
'Columns("A:L").EntireColumn.AutoFit
Columns("A:N").EntireColumn.AutoFit
'Range("A1:L1").Select
Range("A1:N1").Select
Selection.AutoFilter
'Columns("A:L").Select
Columns("A:N").Select
'Columns("A:L").EntireColumn.AutoFit
Columns("A:N").EntireColumn.AutoFit
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
Range("A1").Select
Cells.Select
With Selection
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.UnMerge
'Deletes entire row if cell in Colum L is blank (get rid of dupe entries and blank rows)
Application.ScreenUpdating = False
Columns("L:L").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
'Create Columns for Month Number and for Fiscal Year
Range("M1").Select
ActiveCell.Value = "StartMnth"
Range("M2").Select
ActiveCell.Value = "6"
'Range("M3").Select
'Range("A1").Select
Range("N1").Select
ActiveCell.Value = "Fiscal Year"
Range("N2").Select
ActiveCell.Formula = "=YEAR(J2+(MONTH(J2)>=M2))"
'Range("N3").Select
'Range("A1").Select
'Autofill down Date Formula in M2 to end of data table
Range("M2").AutoFill Range("M2:M" & Range("A" & Rows.Count).End(xlUp).Row)
Range("N2").AutoFill Range("N2:N" & Range("A" & Rows.Count).End(xlUp).Row)
'Format Data and change it to a Table
Cells.Select
With Selection.Font
.Name = "Calibri"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
With Selection.Font
.Name = "Calibri"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Columns("A:N").Select
Columns("A:N").EntireColumn.AutoFit
ActiveWindow.SmallScroll ToRight:=-2
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A:$N"), , xlYes).Name = "Table1"
Columns("A:N").Select
ActiveSheet.ListObjects("Table1").TableStyle = "TableStyleLight1"
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
ActiveWindow.Zoom = 90
'Format Numbers
Range("D:D,G:G,I:I,F:F").Select
Range("Table1[[#Headers],[Departmental Funds]]").Activate
Selection.NumberFormat = "#,##0.00 ;[Red](#,##0.00);- ;"
Range("D1,F1,G1,I1").Select
Range("Table1[[#Headers],[PIF Amount]]").Activate
Selection.NumberFormat = "General"
Range("A1").Select
End Sub
The successful result looks like this:
NDA WARD REPORT.xlsm | ||||||||||||||||
---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|
A | B | C | D | E | F | G | H | I | J | K | L | M | N | |||
1 | Project Grant # | Project Name | Type of Activity | Individual Commitment | Project # | Departmental Funds | Total Ward(s) Commitment | Commitment Date | PIF Amount | PIF Date | Multi-Ward | Ward | StartMnth | Fiscal Year | ||
2 | 14043810 | Harvard Comm. Svcs. Ctr. - CDC Activity Grant | CDC | 250,000.00 | 14047700 | 32,000.00 | 250,000.00 | 6/1/2021 | 282,000.00 | 5/20/2021 | Ward 1 | 6 | 2021 | |||
3 | 14046120 | Bryce Avenue Street Resurfacing | Str. Imprvmnt | 76,190.00 | 14046120 | 76,190.00 | 8/5/2021 | 76,190.00 | 8/5/2021 | Ward 1 | 6 | 2021 | ||||
Master |
Cell Formulas | ||
---|---|---|
Range | Formula | |
N2:N3 | N2 | =YEAR(J2+(MONTH(J2)<=M2)) |
Cells with Conditional Formatting | ||||
---|---|---|---|---|
Cell | Condition | Cell Format | Stop If True | |
A1 | Cell Value | duplicates | text | NO |
A2:A42 | Cell Value | duplicates | text | NO |
This accurate resulting table is actually about 650+ lines.
It now looks like this:
NDA WARD REPORT.xlsm | ||||||||||||||||
---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|
A | B | C | D | E | F | G | H | I | J | K | L | M | N | |||
1 | Project Grant # | Project Name | Type of Activity | Individual Commitment | Project # | Departmental Funds | Total Ward(s) Commitment | Commitment Date | PIF Amount | PIF Date | Multi-Ward | Ward | 6 | #VALUE! | ||
2 | 6 | 1900 | ||||||||||||||
3 | ||||||||||||||||
Master |
Cell Formulas | ||
---|---|---|
Range | Formula | |
N2 | N2 | =YEAR(J2+(MONTH(J2)>=M2)) |
Cells with Conditional Formatting | ||||
---|---|---|---|---|
Cell | Condition | Cell Format | Stop If True | |
A1 | Cell Value | duplicates | text | NO |
I've walked through the code (F8) and can't quite figure out the disconnect. Doesn't seem to be capturing/pasting the data in.
Thanks in advance for the review and guidance.
jski