asked on

Formatting Undefined Number of Worksheets in a Workbook with VBA Macro

I have built a macro that works on one worksheet perfectly, however, the problem is that often there are multiple tabs, but I never know how many (the workbook is an end result of running a report). Is there a way to translate this into formatting each worksheet and then taking worksheets 2-x, copying the data and pasting it below the last row in worksheet 1? Thank you in advance for your help.

Sub FormatManhattanWorkbookPLADJ()
Call sbUnMergeRange
Call sbDeleteARowMulitPL
Call DeleteLast
Call NewColumnNamesPL
Call RefitColumnsPL
End Sub

Sub sbUnMergeRange()
Range("A1:L200000").UnMerge
End Sub

Sub sbDeleteARowMultiCC()
Rows("1:7").Delete
End Sub

Sub DeleteLast()
Dim ws As Worksheet
Dim rng1 As Range
Set ws = Sheets("Page1_1")
Set rng1 = ws.UsedRange.Find("*", ws.[a1], xlValues, , xlByRows, xlPrevious)
If Not rng1 Is Nothing Then rng1.EntireRow.Delete
End Sub

Sub RefitColumnsCC()
Worksheets("Page1_1").Columns("A:L").AutoFit
End Sub

Sub sbDeleteARowMulitPL()
Rows("1:6").Delete
End Sub

Sub RefitColumnsPL()
Worksheets("Page1_1").Columns("A:M").AutoFit
End Sub

Sub NewColumnNamesPL()
Dim ColumnNames(13) As String
Dim a As Integer
Dim Alphabetical As Integer

ColumnNames(1) = "Location"
ColumnNames(2) = "Client ID"
ColumnNames(3) = "Item"
ColumnNames(4) = "Client Item"
ColumnNames(5) = "Item UPC"
ColumnNames(6) = "Resaon Code"
ColumnNames(7) = "Adj Type"
ColumnNames(8) = "Adjustment Units"
ColumnNames(9) = "Adjustment Date"
ColumnNames(10) = "User"
ColumnNames(11) = "PIX Description"
ColumnNames(12) = "Retail Price"
ColumnNames(13) = "Total Adj Price"

With Workbooks("IC Adjustments by Location.xlsx")
With .Worksheets("Page1_1")
With .UsedRange.SpecialCells(xlCellTypeConstants)
For a = .Areas.Count To 1 Step -1
Alphabetical = 1
With .Areas(a)
While (.Cells(1, Alphabetical) <> "" And Alphabetical <= 13)
.Cells(1, Alphabetical).Value = ColumnNames(Alphabetical)
Alphabetical = Alphabetical + 1
Wend
End With
Next a
End With
End With
End With

End Sub

Rob Henson

Sub FormatManhattanWorkbookPLADJ()
Dim Wsht as Worksheet
For Each Wksht in ActiveWorkbook.Worksheets
WkshtName = Wksht.Name
Call sbUnMergeRange
Call sbDeleteARowMulitPL
Call DeleteLast
Call NewColumnNamesPL
Call RefitColumnsPL
Next Wksht

End Sub

In later subs where you specify worksheet name eg "Page 1_1", replace with WkshtName; no need for quotes as it is a variable rather than a hard text value.

gsilouisvilleic

ASKER

I tried the above and I think I must be missing something. I replaced Page1_2 with WkshtName without quotes and got an error on that line and also tried it the way listed below and it's still giving me an error. Is there a piece I'm missing? Thank you for your help.

Sub FormatManhattanWorkbookPLADJ()
Dim Wksht As Worksheet
For Each Wksht In ActiveWorkbook.Worksheets
WkshtName = Wksht.Name
Call sbUnMergeRange
Call sbDeleteARowMulitPL
Call DeleteLast
Call NewColumnNamesPL
Call RefitColumnsPL
Next Wksht
End Sub

Sub sbUnMergeRange()
Range("A1:L200000").UnMerge
End Sub

Sub sbDeleteARowMultiCC()
Rows("1:7").Delete
End Sub

Sub DeleteLast()
Dim ws As Worksheet
Dim rng1 As Range
Set ws = WkshtName
Set rng1 = ws.UsedRange.Find("*", ws.[a1], xlValues, , xlByRows, xlPrevious)
If Not rng1 Is Nothing Then rng1.EntireRow.Delete
End Sub

Rob Henson

Looking at it, because you are using multiple subs which are triggered by one overarching sub, the variables have to be specified as being called from the main sub.

Alternatively, do it all in one sub rather than calling multiple subs.

Sub FormatManhattanWorkbookPLADJ()
Dim Wksht as Worksheet
For Each Wksht in ActiveWorkbook.Worksheets
'Call sbUnMergeRange
'Call sbDeleteARowMulitPL
'Call DeleteLast
'Call NewColumnNamesPL
'Call RefitColumnsPL
'End Sub



'Sub sbUnMergeRange()
Range("A1:L200000").UnMerge
'End Sub

'Sub sbDeleteARowMultiCC()
Rows("1:7").Delete
'End Sub

'Sub DeleteLast()
'Dim ws As Worksheet
Dim rng1 As Range
Set ws = Sheets(Wksht)
Set rng1 = Wksht.UsedRange.Find("*", ws.[a1], xlValues, , xlByRows, xlPrevious)
If Not rng1 Is Nothing Then rng1.EntireRow.Delete
'End Sub

'Sub RefitColumnsCC()
'Worksheets(Wksht).Columns("A:L").AutoFit
'End Sub

'Sub sbDeleteARowMulitPL()
Rows("1:6").Delete
'End Sub

'Sub RefitColumnsPL()
Worksheets(Wksht).Columns("A:M").AutoFit
'End Sub

'Sub NewColumnNamesPL()
Dim ColumnNames(13) As String
Dim a As Integer
Dim Alphabetical As Integer

ColumnNames(1) = "Location"
ColumnNames(2) = "Client ID"
ColumnNames(3) = "Item"
ColumnNames(4) = "Client Item"
ColumnNames(5) = "Item UPC"
ColumnNames(6) = "Resaon Code"
ColumnNames(7) = "Adj Type"
ColumnNames(8) = "Adjustment Units"
ColumnNames(9) = "Adjustment Date"
ColumnNames(10) = "User"
ColumnNames(11) = "PIX Description"
ColumnNames(12) = "Retail Price"
ColumnNames(13) = "Total Adj Price"

With Workbooks("IC Adjustments by Location.xlsx")
    With .Worksheets(Wksht)
        With .UsedRange.SpecialCells(xlCellTypeConstants)
            For a = .Areas.Count To 1 Step -1
                Alphabetical = 1
                With .Areas(a)
                    While (.Cells(1, Alphabetical) <> "" And Alphabetical <= 13)
                        .Cells(1, Alphabetical).Value = ColumnNames(Alphabetical)
                        Alphabetical = Alphabetical + 1
                    Wend
                End With
            Next a
        End With
    End With
End With
Next Wksht
End Sub

Open in new window

The lines that start and stop existing subs have been preceded with an apostrophe, when copied into the VBE these will go green and will not run. There is one section that I have commented out completely; you are AutoFitting columns A to L and then deleting rows and then Autofitting A to M, there is no point doing A to L if it then gets done again for A to M.

Rob Henson

Without the extraneous lines and all Dim statements at the start, it looks like:

Sub FormatManhattanWorkbookPLADJ()
    Dim Wksht As Worksheet
    Dim rng1 As Range
    Dim ColumnNames(13) As String
    Dim a As Integer
    Dim Alphabetical As Integer

For Each Wksht In ActiveWorkbook.Worksheets
    Range("A1:L200000").UnMerge
    Rows("1:7").Delete
    Set rng1 = Wksht.UsedRange.Find("*", ws.[a1], xlValues, , xlByRows, xlPrevious)
    If Not rng1 Is Nothing Then rng1.EntireRow.Delete
    Rows("1:6").Delete
    Worksheets(Wksht).Columns("A:M").AutoFit

    ColumnNames(1) = "Location"
    ColumnNames(2) = "Client ID"
    ColumnNames(3) = "Item"
    ColumnNames(4) = "Client Item"
    ColumnNames(5) = "Item UPC"
    ColumnNames(6) = "Resaon Code"
    ColumnNames(7) = "Adj Type"
    ColumnNames(8) = "Adjustment Units"
    ColumnNames(9) = "Adjustment Date"
    ColumnNames(10) = "User"
    ColumnNames(11) = "PIX Description"
    ColumnNames(12) = "Retail Price"
    ColumnNames(13) = "Total Adj Price"

    With Workbooks("IC Adjustments by Location.xlsx")
        With .Worksheets(Wksht)
            With .UsedRange.SpecialCells(xlCellTypeConstants)
                For a = .Areas.Count To 1 Step -1
                    Alphabetical = 1
                    With .Areas(a)
                        While (.Cells(1, Alphabetical) <> "" And Alphabetical <= 13)
                            .Cells(1, Alphabetical).Value = ColumnNames(Alphabetical)
                            Alphabetical = Alphabetical + 1
                        Wend
                    End With
                Next a
            End With
        End With
    End With
Next Wksht

End Sub

Open in new window

I haven't been able to test properly as I don't have the workbook on which to test it.

gsilouisvilleic

ASKER

I have attached the file that I'm working on. When I tried it, Line 12 came up with an error. Thank you for your help.
C--Users-cspradlin-Documents-IC-Adj.xlsx

Rob Henson

OK, amended in a couple of places; had some confusion over referring to Worksheet by name or as an object:

Sub FormatManhattanWorkbookPLADJ()
    Dim ws As Worksheet
    Dim ShtName As String
    Dim rng1 As Range
    Dim ColumnNames(13) As String
    Dim a As Integer
    Dim Alphabetical As Integer

For Each Wksht In ActiveWorkbook.Worksheets
    ShtName = Wksht.Name
    Range("A1:L200000").UnMerge
    Rows("1:7").Delete
    Set ws = Sheets(ShtName)
    Set rng1 = ws.UsedRange.Find("*", ws.[a1], xlValues, , xlByRows, xlPrevious)
    If Not rng1 Is Nothing Then rng1.EntireRow.Delete
    Rows("1:6").Delete
    Worksheets(ShtName).Columns("A:M").AutoFit

    ColumnNames(1) = "Location"
    ColumnNames(2) = "Client ID"
    ColumnNames(3) = "Item"
    ColumnNames(4) = "Client Item"
    ColumnNames(5) = "Item UPC"
    ColumnNames(6) = "Resaon Code"
    ColumnNames(7) = "Adj Type"
    ColumnNames(8) = "Adjustment Units"
    ColumnNames(9) = "Adjustment Date"
    ColumnNames(10) = "User"
    ColumnNames(11) = "PIX Description"
    ColumnNames(12) = "Retail Price"
    ColumnNames(13) = "Total Adj Price"

    With ActiveWorkbook
        With .Worksheets(ShtName)
            With .UsedRange.SpecialCells(xlCellTypeConstants)
                For a = .Areas.Count To 1 Step -1
                    Alphabetical = 1
                    With .Areas(a)
                        While (.Cells(1, Alphabetical) <> "" And Alphabetical <= 13)
                            .Cells(1, Alphabetical).Value = ColumnNames(Alphabetical)
                            Alphabetical = Alphabetical + 1
                        Wend
                    End With
                Next a
            End With
        End With
    End With
Next Wksht

End Sub

Open in new window

This doesn't crash but it doesn't add the column headers.

Rob Henson

Turns out it was adding the headers but they were getting removed because one fairly crucial line omitted, apologies. Insert a line after current line 10 and add:

Sheets(ShtName).Select

to give:

For Each Wksht In ActiveWorkbook.Worksheets
ShtName = Wksht.Name
Sheets(ShtName).Select

I noticed that your code is deleting rows 1 to 6 and then later deleting rows 1 to 7; 1 to 6 removes the headers but 1 to 7 is then removing the first 7 rows of data. Is that correct, I suspect not.

Thanks

gsilouisvilleic

ASKER

You are right, it isn't correct. I was also working on a similar but different macro for another workbook and accidentally left it in there, sorry. It did everything perfectly, but I guess my next question, if you wouldn't mind helping me with it, would be the part of taking all data under the headers on worksheets 2-X and pasting them below the last row of data in the first workbook (Page1_1). I've been looking around to see if there was something I could use, but can't seem to find anything that works for this particular set of circumstances.

Rob Henson

Away from pc now. Should get chance to look tomorrow.

Shums Faruk

Please try below, all in one code which will work on every sheets:

Sub FormatManhattanWorkbook()
Dim Ws As Worksheet
Dim Rng As Range
Dim ColumnNames(13) As String
Dim a As Integer
Dim Alphabetical As Integer
Application.ScreenUpdating = False
ColumnNames(1) = "Location"
ColumnNames(2) = "Client ID"
ColumnNames(3) = "Item"
ColumnNames(4) = "Client Item"
ColumnNames(5) = "Item UPC"
ColumnNames(6) = "Resaon Code"
ColumnNames(7) = "Adj Type"
ColumnNames(8) = "Adjustment Units"
ColumnNames(9) = "Adjustment Date"
ColumnNames(10) = "User"
ColumnNames(11) = "PIX Description"
ColumnNames(12) = "Retail Price"
ColumnNames(13) = "Total Adj Price"

For Each Ws In Sheets
    Ws.UsedRange.UnMerge 'UnMergeRange
    Ws.Rows("1:6").EntireRow.Delete 'DeleteRows
    Set Rng = Ws.UsedRange.Find("*", Ws.[A1], xlValues, , xlByRows, xlPrevious)
    If Not Rng Is Nothing Then Rng.EntireRow.Delete 'Delete Last Column
    Ws.Columns("A:M").AutoFit 'RefitColumns
    'NewColumnNamesPL
    With Ws.UsedRange.SpecialCells(xlCellTypeConstants)
        For a = .Areas.Count To 1 Step -1
            Alphabetical = 1
            With .Areas(a)
                While (.Cells(1, Alphabetical) <> "" And Alphabetical <= 13)
                    .Cells(1, Alphabetical).Value = ColumnNames(Alphabetical)
                    Alphabetical = Alphabetical + 1
                Wend
            End With
        Next a
    End With
Next Ws
Application.ScreenUpdating = True
End Sub

Open in new window

Shums Faruk

Move your Column Autofit after all the process, else it will disturb Column Width:

Sub FormatManhattanWorkbook()
Dim Ws As Worksheet
Dim Rng As Range
Dim ColumnNames(13) As String
Dim a As Integer
Dim Alphabetical As Integer
Application.ScreenUpdating = False
ColumnNames(1) = "Location"
ColumnNames(2) = "Client ID"
ColumnNames(3) = "Item"
ColumnNames(4) = "Client Item"
ColumnNames(5) = "Item UPC"
ColumnNames(6) = "Resaon Code"
ColumnNames(7) = "Adj Type"
ColumnNames(8) = "Adjustment Units"
ColumnNames(9) = "Adjustment Date"
ColumnNames(10) = "User"
ColumnNames(11) = "PIX Description"
ColumnNames(12) = "Retail Price"
ColumnNames(13) = "Total Adj Price"

For Each Ws In Sheets
    Ws.UsedRange.UnMerge 'UnMergeRange
    Ws.Rows("1:6").EntireRow.Delete 'DeleteRows
    Set Rng = Ws.UsedRange.Find("*", Ws.[A1], xlValues, , xlByRows, xlPrevious)
    If Not Rng Is Nothing Then Rng.EntireRow.Delete 'Delete Last Column
    'NewColumnNamesPL
    With Ws.UsedRange.SpecialCells(xlCellTypeConstants)
        For a = .Areas.Count To 1 Step -1
            Alphabetical = 1
            With .Areas(a)
                While (.Cells(1, Alphabetical) <> "" And Alphabetical <= 13)
                    .Cells(1, Alphabetical).Value = ColumnNames(Alphabetical)
                    Alphabetical = Alphabetical + 1
                Wend
            End With
        Next a
    End With
    Ws.Columns("A:M").AutoFit 'RefitColumns
Next Ws
Application.ScreenUpdating = True
End Sub

Open in new window

Please find attached your sample workbook for reference.
C--Users-cspradlin-Documents-IC-Adj.xlsm

SOLUTION

Rob Henson

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

gsilouisvilleic

ASKER

Thank all for the help! :)

ASKER CERTIFIED SOLUTION