Rose401k

New Member
Joined
Aug 14, 2018
Messages
8
Hello everyone! I am a pretty beginner vba user and having some trouble getting a loop to work. I have a pretty extensive formatting code here, which works perfectly on a single worksheet. When I then try to have it loop through every single worksheet in the workbook except for the "Original" tab, it either doesn't work properly, or crashes and shuts down. My first thought is that perhaps it is the size of my workbook, which ends up having around 300 worksheets in it. Any advice or tips would be greatly appreciated as I am new to loops in general. Thanks so much!!

Code:
My loop code:
Sub Format()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim ws as worksheet
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Original" Then
    *****My format code is here******
        End If
    Next ws
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End sub

The format code is below. This is the section that works on a run through a single worksheet, but not within the loop. Apologies for posting the full macro here but I'm just hoping I've goofed something in it which explains why it won't work:

'Plan Name
    Rows("1:3").Select
    Selection.Insert shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("B5").Copy
    Range("F2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
'Delete unneccesary columns
    Columns("A:E").Delete shift:=xlToLeft
    Columns("A:E").EntireColumn.AutoFit
    Columns("B:D").Delete shift:=xlToLeft
    Columns("F:F").Delete shift:=xlToLeft
    Columns("G:G").Delete shift:=xlToLeft
    Columns("F:F").Select
    Selection.Cut
    Columns("I:I").Select
    Selection.Insert shift:=xlToRight
    Columns("C:C").Delete shift:=xlToLeft
    Columns("D:D").Delete shift:=xlToLeft
'Delete Paying Agent Rows Using Column D
    Last = Cells(Rows.Count, "D").End(xlUp).Row
    For i = Last To 1 Step -1
        If (Cells(i, "D").Value) = "Paying Agent" Then
        Cells(i, "A").EntireRow.Delete
        End If
        Next i
'Format Styles and Enter Headers
    Columns("C:C").Select
    Selection.Delete shift:=xlToLeft
    Columns("E:E").Select
    Selection.Cut
    Columns("C:C").Select
    Selection.Insert shift:=xlToRight
    Columns("D:D").EntireColumn.AutoFit
    Rows("5:5").Select
    Selection.Insert shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A4").Select
    ActiveCell.FormulaR1C1 = "Category"
    Range("B4").Select
    ActiveCell.FormulaR1C1 = "Paid By"
    Range("E4").Select
    ActiveCell.FormulaR1C1 = "Allocation Basis"
    Range("F4").Select
    ActiveCell.FormulaR1C1 = "Description"
    Range("A2:F2").Select
    Selection.Style = "Heading 1"
    Rows("2:2").EntireRow.AutoFit
    Range("A4:F4").Select
    Selection.Style = "Heading 4"
    Columns("F:F").ColumnWidth = 54.57
'Amount Value Formulas
    'Formula MID(E6,SEARCH("$",E6),SEARCH("e",E6)-3)    "=MID(E6,SEARCH(""$"",E6),SEARCH(""e"",E6)-3"
    'Range("A1").Select
    'Dim rng1 As Range, c1 As Range
    'Set rng1 = Range("A5:A25")
   ' For Each c1 In rng1
         'If InStr(1, c1.Value, "Accountholder Administration") > 0 Then c1.Offset(0, 2).Formula = "=RC[3]"
   ' Next
    'LEFT(E7,SEARCH("of",E7)-2)
    Range("A1").Select
    Dim rnga As Range, ca As Range
    Set rnga = Range("A5:A25")
    For Each ca In rnga
         If InStr(1, ca.Value, "Asset Support & Recordkeeping") > 0 Then ca.Offset(0, 2).Formula = "=LEFT(RC[2],SEARCH(""of"",RC[2])-2)"
    Next
    'LEFT(E8,SEARCH("of",E8)-2)
    For Each ca In rnga
         If InStr(1, ca.Value, "Investment Advisor Compensation") > 0 Then ca.Offset(0, 2).Formula = "=LEFT(RC[2],SEARCH(""of"",RC[2])-2)"
    Next
    For Each ca In rnga
         If InStr(1, ca.Value, "Plan Administration") > 0 Then ca.Offset(0, 2).Formula = "=RC[2]"
    Next
   
    Columns("C:C").EntireColumn.AutoFit
    Columns("C:C").Copy
    Columns("C:C").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    With Selection
        .HorizontalAlignment = xlRight
    End With
    Range("C4").HorizontalAlignment = xlLeft
    Range("C4").Value = "Amount"
'HardCode Values Part 1
    Dim rng As Range, c As Range
    Set rng = Range("A5:A25")
    For Each c In rng
        If InStr(1, c.Value, "Accountholder Administration") > 0 Then c.Offset(0, 5).Value = "Ongoing support and compliance of participant activities"
    Next
    For Each c In rng
        If InStr(1, c.Value, "Asset Support & Recordkeeping") > 0 Then c.Offset(0, 5).Value = "Recordkeeping, online account management, and benefit statements"
    Next
    For Each c In rng
        If InStr(1, c.Value, "Investment Advisor Compensation") > 0 Then c.Offset(0, 5).Value = "Investment advisory services"
    Next
    For Each c In rng
        If InStr(1, c.Value, "Plan Administration") > 0 Then c.Offset(0, 5).Value = "Annual government compliance testing and reporting"
    Next
    Columns("F:F").Copy
    Columns("F:F").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
'Allocation Basis Column
    Columns("E:E").EntireColumn.AutoFit
    Range("A1").Select
    Dim rng2 As Range, c2 As Range
    Set rng2 = Range("B6:B25")
    For Each c2 In rng2
         If InStr(1, c2.Value, "Plan") > 0 Then c2.Offset(0, 2).Value = "Paid by Participant, pro-rata on balances, quarterly in arrears"
    Next
    For Each c2 In rng2
         If InStr(1, c2.Value, "Employer") > 0 Then c2.Offset(0, 2).Value = "Paid by Employer, quarterly in arrears"
    Next
    For Each c2 In rng2
         If InStr(1, c2.Value, "Employer - Recurring") > 0 Then c2.Offset(0, 2).Value = "Paid by Employer, quarterly in arrears"
    Next
    Columns("E:E").Delete shift:=xlToLeft
    Columns("D:D").EntireColumn.AutoFit
'HardCode Values Part 2
    Range("A" & Rows.Count).End(xlUp).Offset(1).Select
    Selection.Value = "Custody"
    Selection.Offset(0, 1).Formula = "=INDEX(A:B,MATCH(""Pass-through"",A:A,0),2)"
    Selection.Offset(0, 2).Value = "6.5 Basis Points"
    Selection.Offset(0, 3).Formula = "=IF(RC[-2]=""Plan"",""Deducted from Participant account, quarterly in arrears"",""Paid By Employer, quarterly in arrears"")"
    Selection.Offset(0, 4).Value = "Holding of plan's financial assets"
        Range("A" & Rows.Count).End(xlUp).Offset(1).Select
    Selection.Value = "Trading, Clearing, & Settlement"
    Selection.Offset(0, 1).Formula = "=INDEX(A:B,MATCH(""Pass-through"",A:A,0),2)"
    Selection.Offset(0, 2).Value = "0.07 Per Transaction"
    Selection.Offset(0, 3).Formula = "=IF(RC[-2]=""Plan"",""Deducted from Participant account, quarterly in arrears"",""Paid By Employer, quarterly in arrears"")"
    Selection.Offset(0, 4).Value = "Investment of the plan's financial assets"
    Columns("B:D").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
   
    Range("A" & Rows.Count).End(xlUp).Offset(1).Select
    Selection.Value = "Distribution"
    Selection.Offset(0, 1).Value = "Participant"
    Selection.Offset(0, 2).Value = "$75 Per Distribution"
    Selection.Offset(0, 3).Value = "Deducted from Participant account"
    Selection.Offset(0, 4).Value = "Distribution processing including tax form generation"
        Range("A" & Rows.Count).End(xlUp).Offset(1).Select
    Selection.Value = "Inservice/Hardship"
    Selection.Offset(0, 1).Value = "Participant"
    Selection.Offset(0, 2).Value = "$85 Per Withdrawal"
    Selection.Offset(0, 3).Value = "Deducted from Participant account"
    Selection.Offset(0, 4).Value = "Hardship or Inservice withdrawal processing including tax form generation"
        Range("A" & Rows.Count).End(xlUp).Offset(1).Select
    Selection.Value = "Loan Origination"
    Selection.Offset(0, 1).Value = "Participant"
    Selection.Offset(0, 2).Value = "$100 Per Loan"
    Selection.Offset(0, 3).Value = "Deducted from Participant account"
    Selection.Offset(0, 4).Value = "Loan Initiation and first year maintenance"
        Range("A" & Rows.Count).End(xlUp).Offset(1).Select
    Selection.Value = "Loan Maintenance"
    Selection.Offset(0, 1).Value = "Participant"
    Selection.Offset(0, 2).Value = "$85 Per Loan"
    Selection.Offset(0, 3).Value = "Deducted from Participant account"
    Selection.Offset(0, 4).Value = "Ongoing loan maintenance, including loan repayment processing"
        Range("A" & Rows.Count).End(xlUp).Offset(1).Select
    Selection.Value = "Participant QDRO"
    Selection.Offset(0, 1).Value = "Participant"
    Selection.Offset(0, 2).Value = "$150 Minimum"
    Selection.Offset(0, 3).Value = "Deducted from Participant account"
    Selection.Offset(0, 4).Value = "QDRO processing"
       
'Delete Pass-Through Rows Using Column A
    Last1 = Cells(Rows.Count, "A").End(xlUp).Row
    For i1 = Last1 To 1 Step -1
        If (Cells(i1, "A").Value) = "Pass-through" Then
        Cells(i1, "A").EntireRow.Delete
        End If
        Next i1
 
'Final Format
    Columns("B:E").HorizontalAlignment = xlLeft
    Columns("B:E").EntireColumn.AutoFit
    Columns("C:C").NumberFormat = "$#,##0.00_);($#,##0.00)"
    Range("A1").Select
    Cells.Replace What:="Employer - Recurring", Replacement:="Employer", _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
        False, ReplaceFormat:=False
'Set Print Area
ActiveSheet.PageSetup.PrintArea = "$A$1:$F$25"
'Print Settings
With ActiveSheet.PageSetup
    '.PrintTitleRows = "$3:$3"
    '.PrintTitleColumns = "$B:$B"
    .Orientation = xlLandscape
    .Zoom = False
    .FitToPagesWide = 1
    .FitToPagesTall = 1
End With
 
Last edited by a moderator:

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.
Hi Rose401k,

Which line of code specifically does the error occur on? Clicking the "debug" button once the error occurs will highlight the line of code that caused the error.


All the best,
Matt
 
Upvote 0
Your code crashes because you are using Select in your formatting code, you can only Select on the Activesheet.

You also need to reference ws on all ranges, cells, rows and columns.
 
Last edited:
Upvote 0
As a rough guide as untested so I am bound to have missed something...

Rich (BB code):
Sub Formatit()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Original" Then
            'Plan Name
            With ws
                .Rows("1:3").Insert shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                
                .Range("F2").Value = .Range("B5").Value
                
                'Delete unneccesary columns
                .Columns("A:E").Delete shift:=xlToLeft
                .Columns("A:E").EntireColumn.AutoFit
                .Columns("B:D").Delete shift:=xlToLeft
                .Columns("F:F").Delete shift:=xlToLeft
                .Columns("G:G").Delete shift:=xlToLeft
                .Columns("F:F").Cut
                .Columns("I:I").Insert shift:=xlToRight
                .Columns("C:C").Delete shift:=xlToLeft
                .Columns("D:D").Delete shift:=xlToLeft
                'Delete Paying Agent Rows Using Column D
                Last = .Cells(Rows.Count, "D").End(xlUp).Row
                For i = Last To 1 Step -1
                    If .Cells(i, "D").Value = "Paying Agent" Then
                        .Cells(i, "A").EntireRow.Delete
                    End If
                Next i
                'Format Styles and Enter Headers
                .Columns("C:C").Delete shift:=xlToLeft
                .Columns("E:E").Cut
                .Columns("C:C").Insert shift:=xlToRight
                .Columns("D:D").EntireColumn.AutoFit
                .Rows("5:5").Insert shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                .Range("A4").Value = "Category"
                .Range("B4").Value = "Paid By"
                .Range("E4").Value = "Allocation Basis"
                .Range("F4").Value = "Description"
                .Range("A2:F2").Style = "Heading 1"
                .Rows("2:2").EntireRow.AutoFit
                .Range("A4:F4").Style = "Heading 4"
                .Columns("F:F").ColumnWidth = 54.57
                'Amount Value Formulas
                'Formula MID(E6,SEARCH("$",E6),SEARCH("e",E6)-3)    "=MID(E6,SEARCH(""$"",E6),SEARCH(""e"",E6)-3"
                'Range("A1").Select
                'Dim rng1 As Range, c1 As Range
                'Set rng1 = Range("A5:A25")
                ' For Each c1 In rng1
                'If InStr(1, c1.Value, "Accountholder Administration") > 0 Then c1.Offset(0, 2).Formula = "=RC[3]"
                ' Next
                'LEFT(E7,SEARCH("of",E7)-2)

                Dim rnga As Range, ca As Range
                Set rnga = .Range("A5:A25")
                For Each ca In rnga
                    If InStr(1, ca.Value, "Asset Support & Recordkeeping") > 0 Then ca.Offset(0, 2).Formula = "=LEFT(RC[2],SEARCH(""of"",RC[2])-2)"
                Next
                'LEFT(E8,SEARCH("of",E8)-2)
                For Each ca In rnga
                    If InStr(1, ca.Value, "Investment Advisor Compensation") > 0 Then ca.Offset(0, 2).Formula = "=LEFT(RC[2],SEARCH(""of"",RC[2])-2)"
                Next
                For Each ca In rnga
                    If InStr(1, ca.Value, "Plan Administration") > 0 Then ca.Offset(0, 2).Formula = "=RC[2]"
                Next

                .Columns("C:C").EntireColumn.AutoFit
                .Columns("C:C").Value = .Columns("C:C").Value
                .Columns("C:C").HorizontalAlignment = xlRight

                .Range("C4").HorizontalAlignment = xlLeft
                .Range("C4").Value = "Amount"
                'HardCode Values Part 1
                Dim rng As Range, c As Range
                Set rng = .Range("A5:A25")
                For Each c In rng
                    If InStr(1, c.Value, "Accountholder Administration") > 0 Then c.Offset(0, 5).Value = "Ongoing support and compliance of participant activities"
                Next
                For Each c In rng
                    If InStr(1, c.Value, "Asset Support & Recordkeeping") > 0 Then c.Offset(0, 5).Value = "Recordkeeping, online account management, and benefit statements"
                Next
                For Each c In rng
                    If InStr(1, c.Value, "Investment Advisor Compensation") > 0 Then c.Offset(0, 5).Value = "Investment advisory services"
                Next
                For Each c In rng
                    If InStr(1, c.Value, "Plan Administration") > 0 Then c.Offset(0, 5).Value = "Annual government compliance testing and reporting"
                Next
                .Columns("F:F").Value = .Columns("F:F").Value
               
                'Allocation Basis Column
                .Columns("E:E").EntireColumn.AutoFit

                Dim rng2 As Range, c2 As Range
                Set rng2 = .Range("B6:B25")
                For Each c2 In rng2
                    If InStr(1, c2.Value, "Plan") > 0 Then c2.Offset(0, 2).Value = "Paid by Participant, pro-rata on balances, quarterly in arrears"
                Next
                For Each c2 In rng2
                    If InStr(1, c2.Value, "Employer") > 0 Then c2.Offset(0, 2).Value = "Paid by Employer, quarterly in arrears"
                Next
                For Each c2 In rng2
                    If InStr(1, c2.Value, "Employer - Recurring") > 0 Then c2.Offset(0, 2).Value = "Paid by Employer, quarterly in arrears"
                Next
                .Columns("E:E").Delete shift:=xlToLeft
                .Columns("D:D").EntireColumn.AutoFit
                'HardCode Values Part 2
                With .Range("A" & Rows.Count).End(xlUp).Offset(1)
                    .Value = "Custody"
                    .Offset(0, 1).Formula = "=INDEX(A:B,MATCH(""Pass-through"",A:A,0),2)"
                    .Offset(0, 2).Value = "6.5 Basis Points"
                    .Offset(0, 3).Formula = "=IF(RC[-2]=""Plan"",""Deducted from Participant account, quarterly in arrears"",""Paid By Employer, quarterly in arrears"")"
                    .Offset(0, 4).Value = "Holding of plan's financial assets"
                End With
                With .Range("A" & Rows.Count).End(xlUp).Offset(1)
                    .Value = "Trading, Clearing, & Settlement"
                    .Offset(0, 1).Formula = "=INDEX(A:B,MATCH(""Pass-through"",A:A,0),2)"
                    .Offset(0, 2).Value = "0.07 Per Transaction"
                    .Offset(0, 3).Formula = "=IF(RC[-2]=""Plan"",""Deducted from Participant account, quarterly in arrears"",""Paid By Employer, quarterly in arrears"")"
                    .Offset(0, 4).Value = "Investment of the plan's financial assets"
                End With
                .Columns("B:D").Value = .Columns("B:D").Value

                With .Range("A" & Rows.Count).End(xlUp).Offset(1)
                    .Value = "Distribution"
                    .Offset(0, 1).Value = "Participant"
                    .Offset(0, 2).Value = "$75 Per Distribution"
                    .Offset(0, 3).Value = "Deducted from Participant account"
                    .Offset(0, 4).Value = "Distribution processing including tax form generation"
                End With

                With .Range("A" & Rows.Count).End(xlUp).Offset(1)
                    .Value = "Inservice/Hardship"
                    .Offset(0, 1).Value = "Participant"
                    .Offset(0, 2).Value = "$85 Per Withdrawal"
                    .Offset(0, 3).Value = "Deducted from Participant account"
                    .Offset(0, 4).Value = "Hardship or Inservice withdrawal processing including tax form generation"
                End With
                With .Range("A" & Rows.Count).End(xlUp).Offset(1)
                    .Value = "Loan Origination"
                    .Offset(0, 1).Value = "Participant"
                    .Offset(0, 2).Value = "$100 Per Loan"
                    .Offset(0, 3).Value = "Deducted from Participant account"
                    .Offset(0, 4).Value = "Loan Initiation and first year maintenance"
                End With
                With .Range("A" & Rows.Count).End(xlUp).Offset(1)
                    .Value = "Loan Maintenance"
                    .Offset(0, 1).Value = "Participant"
                    .Offset(0, 2).Value = "$85 Per Loan"
                    .Offset(0, 3).Value = "Deducted from Participant account"
                    .Offset(0, 4).Value = "Ongoing loan maintenance, including loan repayment processing"
                End With
                With .Range("A" & Rows.Count).End(xlUp).Offset(1)
                    .Value = "Participant QDRO"
                    .Offset(0, 1).Value = "Participant"
                    .Offset(0, 2).Value = "$150 Minimum"
                    .Offset(0, 3).Value = "Deducted from Participant account"
                    .Offset(0, 4).Value = "QDRO processing"
                End With
                'Delete Pass-Through Rows Using Column A
                Last1 = .Cells(Rows.Count, "A").End(xlUp).Row
                For i1 = Last1 To 1 Step -1
                    If .Cells(i1, "A").Value = "Pass-through" Then
                        .Cells(i1, "A").EntireRow.Delete
                    End If
                Next i1

                'Final Format
                .Columns("B:E").HorizontalAlignment = xlLeft
                .Columns("B:E").EntireColumn.AutoFit
                .Columns("C:C").NumberFormat = "$#,##0.00_);($#,##0.00)"

                .Cells.Replace What:="Employer - Recurring", Replacement:="Employer", _
                               LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
                               False, ReplaceFormat:=False
                'Set Print Area
            End With
            ws.PageSetup.PrintArea = "$A$1:$F$25"
            'Print Settings
            With ws.PageSetup
                '.PrintTitleRows = "$3:$3"
                '.PrintTitleColumns = "$B:$B"
                .Orientation = xlLandscape
                .Zoom = False
                .FitToPagesWide = 1
                .FitToPagesTall = 1
            End With
        End If
    Next ws
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
 
Last edited:
Upvote 0
My first thought is what you are describing sounds like an infinite loop. Try putting break points at the beginning of each of your loops. Use F5 to jump from loop to loop. Keep track of where you are. This will show you which of your loops is causing the hangup. That is of course if it is the infinite loop crash at all.

I would check these two loops.

Code:
    For i = Last To 1 Step -1        
    If .Cells(i, "D").Value = "Paying Agent" Then
            .Cells(i, "A").EntireRow.Delete
        End If
    Next i

Code:
    For i1 = Last1 To 1 Step -1        
    If (.Cells(i1, "A").Value) = "Pass-through" Then
            .Cells(i1, "A").EntireRow.Delete
        End If
    Next i1

I am curious what would happen if your Last or Last1 values started off as empty, null, or 0..
Either way, those are your only two loops I noticed that could potentially infinite loop.
 
Last edited:
Upvote 0
I am curious what would happen if your Last or Last1 values started off as empty, null, or 0

They can't, an empty column produces a 1 with Cells(Rows.Count, "A").End(xlUp).Row

Code:
Sub ddd()
Dim Last1 As Long
Last1 = Cells(Rows.Count, "A").End(xlUp).Row
MsgBox Last1
End Sub

as you you can't have a zero row.
 
Upvote 0

Forum statistics

Threads
1,215,455
Messages
6,124,935
Members
449,195
Latest member
Stevenciu

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