VBA Code for Table From Specific Range in Multiple Worksheets Not Working

[jski21]

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:

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

 

[DanteAmor]

I've walked through the code (F8) and can't quite figure out the disconnect.

The macro copies the data well.
Considering the following:
- The data begins after row 4.
(startRow = headers.Row + 4)
- Have data in column "L".
(Columns("L:L").SpecialCells(xlCellTypeBlanks).EntireRow.Delete)

I checked the macro and removed some lines that are not necessary (about 93 lines)
Try this:

Sub Merge_Sheets()
  Dim headers As Range
  Dim mtr As Worksheet, ws As Worksheet
  Dim startRow As Long, startCol As Long, lastRow As Long, lr As Long
  Dim lastCol As Long, mstStrRow As Long, i As Long, j As Long, noCopyCols As Long
 
  Application.DisplayAlerts = False
  On Error Resume Next
  Sheets("Master").Delete
  On Error GoTo 0
 
  'Set Master sheet for consolidation
  Sheets.Add(After:=Sheets("17")).Name = "Master"
  Set mtr = Worksheets("Master")
 
  '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 Worksheets
    Select Case ws.Name
      Case "Master", "Tables", "NDAForm", "NDAForm (2)", "Ordinances", _
           "BudgetAdj", "NDA Summary", "Pivot", "Charts"
      Case Else
        lastRow = ws.Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
        mstStrRow = mtr.Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row + 1
        'Get data from each worksheet and copy it into Master sheet
        ws.Range(ws.Cells(startRow, startCol), ws.Cells(lastRow, lastCol)).Copy
        mtr.Range("A" & mstStrRow).PasteSpecial xlPasteValues
        mtr.Range("A" & mstStrRow).PasteSpecial xlPasteFormats
    End Select
  Next ws
 
  'Format the data
  mtr.Select
  With Range("A1:N1")
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Font.Underline = xlUnderlineStyleSingle
    .Font.Bold = True
  End With
 
  With Cells
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
    .UnMerge
    'Format Data and change it to a Table
    .Font.Name = "Calibri"
    .Font.Size = 10
  End With
 
  'Deletes entire row if cell in Colum L is blank (get rid of dupe entries and blank rows)
  Columns("L:L").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
 
  'Create Columns for Month Number and for Fiscal Year
  Range("M1").Value = "StartMnth"
  Range("M2").Value = "6"
  Range("N1").Value = "Fiscal Year"
  Range("N2").Formula = "=YEAR(J2+(MONTH(J2)>=M2))"
 
  'Autofill down Date Formula in M2 to end of data table
  lr = Range("A" & Rows.Count).End(xlUp).Row
  If lr > 2 Then
    Range("M2").AutoFill Range("M2:M" & lr)
    Range("N2").AutoFill Range("N2:N" & lr)
  End If
  Columns("A:N").EntireColumn.AutoFit
  ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A1:$N" & lr), , xlYes).Name = "Table1"
  ActiveSheet.ListObjects("Table1").TableStyle = "TableStyleLight1"
 
  With ActiveWindow
    .SplitColumn = 0
    .SplitRow = 1
    .FreezePanes = True
    .Zoom = 90
  End With
 
  'Format Numbers
  Range("D:D,G:G,I:I,F:F").NumberFormat = "#,##0.00 ;[Red](#,##0.00);- ;"
  Range("D1,F1,G1,I1").NumberFormat = "General"
  Range("A1").Select
End Sub

 

[jski21]

Thanks DanteAmor. Your version fixed the issue and ran much swifter. Appreciate your time and help. I plan to walk through this vs. the older version to see where I can obviously improve my VBA.

Enjoy your day and thank again!

jski

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.