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

jski21

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

NDA WARD REPORT.xlsm
ABCDEFGHIJKLMN
1Project Grant #Project NameType of ActivityIndividual CommitmentProject #Departmental FundsTotal Ward(s) CommitmentCommitment DatePIF AmountPIF DateMulti-WardWardStartMnthFiscal Year
214043810Harvard Comm. Svcs. Ctr. - CDC Activity GrantCDC250,000.001404770032,000.00250,000.006/1/2021282,000.005/20/2021Ward 162021
314046120Bryce Avenue Street ResurfacingStr. Imprvmnt76,190.001404612076,190.008/5/202176,190.008/5/2021Ward 162021
Master
Cell Formulas
RangeFormula
N2:N3N2=YEAR(J2+(MONTH(J2)<=M2))
Cells with Conditional Formatting
CellConditionCell FormatStop If True
A1Cell ValueduplicatestextNO
A2:A42Cell ValueduplicatestextNO


This accurate resulting table is actually about 650+ lines.


It now looks like this:

NDA WARD REPORT.xlsm
ABCDEFGHIJKLMN
1Project Grant #Project NameType of ActivityIndividual CommitmentProject #Departmental FundsTotal Ward(s) CommitmentCommitment DatePIF AmountPIF DateMulti-WardWard6#VALUE!
261900
3
Master
Cell Formulas
RangeFormula
N2N2=YEAR(J2+(MONTH(J2)>=M2))
Cells with Conditional Formatting
CellConditionCell FormatStop If True
A1Cell ValueduplicatestextNO



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
 

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
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:

VBA Code:
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
 
Upvote 0
Solution
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
 
Upvote 0
I'm glad to help you. Thanks for the feedback.
 
Upvote 0

Forum statistics

Threads
1,223,893
Messages
6,175,240
Members
452,621
Latest member
Laura_PinksBTHFT

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
Back
Top