Looping Macro through all worksheets - Urgent please :(

lyyynnnchy · Sep 10, 2014

Hi,

I'm trying to loop the following Macro through all my worksheets but it get's stuck on the first worksheet and just keeps repeating, never moving to the next worksheet?

This is the Macro I want to loop

Code:

Sub AMgmtFirstMacroForecast()    Application.Calculation = xlCalculationAutomatic
    ActiveWindow.DisplayHeadings = True
    Application.Run "PERSONAL.XLSB!MgmtDelAfterUnallocated"
    Application.Run "PERSONAL.XLSB!MgmtReportRowTidyUpOtherForecast"
    Application.Run "PERSONAL.XLSB!DeleteExcessHeadingsOtherForecast"
    Application.Run "PERSONAL.XLSB!RemoveOtherGovtExpHeading"
    Application.Run "PERSONAL.XLSB!RemoveCapPurchasesExpHeading"
    Application.Run "PERSONAL.XLSB!InsertBlankRowsOtherForecast"
    Application.Run "PERSONAL.XLSB!InsCorpServHeading"
    Columns("J:K").Select
    Selection.ClearContents
    Selection.AutoFilter
    Selection.AutoFilter
    Application.Run "PERSONAL.XLSB!LandscapeLayoutForecast"
        
    'Body Header Colour and Border
    Range("A6:I8").Select
    With Selection.Interior
        .ThemeColor = xlThemeColorAccent3
    End With
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("A1").Select
End Sub
Sub MgmtReportRowTidyUpOtherForecast()
  
    Application.Run "PERSONAL.XLSB!MgmtHeadingTidyUpForecast"
    Application.Run "PERSONAL.XLSB!MgmtReportAccCleanUpForecast"
    
    'delete blank rows
    Range("J8").Select
    Range("J9").FormulaR1C1 = "=COUNTIF(RC[-9]:RC[-1],"""")"
    Range("J9").Copy
    Range("J10:J310").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("J8:J310").Select
    Selection.AutoFilter Field:=1, Criteria1:="9"
    Rows("9:310").Select
    Selection.delete Shift:=xlUp
    Selection.AutoFilter Field:=1
    
'    Selection.AutoFilter Field:=1, Criteria1:="8"
 '   Rows("9:300").Select
  '  Selection.delete Shift:=xlUp
   ' Selection.AutoFilter Field:=1
    
    'Application.Run "PERSONAL.XLSB!ActiveRowsOnSheetUpdated"
    Application.Run "PERSONAL.XLSB!FormulaInColumnKForecast"
 
    Range("J:K").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A1").Select
End Sub
Sub MgmtReportAccCleanUpForecast()
    'Tidy up ColumnA Body
    Columns("A:A").Select
    Selection.Replace What:="Default", Replacement:=" ", LookAt:=xlPart, _
        SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="Consultants", Replacement:=" ", LookAt:=xlPart, _
        SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    'Selection.Replace What:="Legal Advice ", Replacement:=" ", LookAt:=xlPart, _
        SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    'Selection.Replace What:="Contractors ", Replacement:=" ", LookAt:=xlPart, _
        SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="Misc Suppliers", Replacement:="Misc Consultants", _
        LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat _
        :=False, ReplaceFormat:=False
    Range("J9").Select
    ActiveCell.FormulaR1C1 = "=TRIM(RC[-9])"
    Selection.Copy


    Range("J10:J310").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("J9").Select
    Range(Selection, Selection.End(xlDown)).Copy
    Range("A9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("J:J").ClearContents
    Range("A9:A310").Select
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    
    Range("A1").Select
End Sub
Sub MgmtDelAfterUnallocated()


    Cells.Find(What:="unallocated cost", After:=ActiveCell, LookIn:= _
        xlFormulas, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:= _
        xlNext, MatchCase:=False, SearchFormat:=False).Activate


Dim strUnallocatedCostRow As Long
Dim myLastRow As Long
Dim myRemoveTrailingRow As Long


    strUnallocatedCostRow = ActiveCell.Row
    myLastRow = Cells(Rows.Count, ActiveCell.Column).End(xlUp).Row


    ActiveCell.Offset(1, 0).Select


    For myRemoveTrailingRow = strUnallocatedCostRow To myLastRow
        Selection.EntireRow.delete Shift:=xlUp
    Next myRemoveTrailingRow
End Sub
Sub MgmtHeadingTidyUpForecast()
    'unmerge date etc headings and move to Row C and tidy them up
    Range("A4:J4").Select
    Selection.UnMerge
    Range("A5:J5").Select
    Selection.UnMerge
    Range("A6:J6").Select
    Selection.UnMerge
    Range("B4:B6").Select
    Selection.Cut
    Range("C4").Select
    ActiveSheet.Paste
    Range("C5").Select
        ActiveCell.Replace What:=" AUD", Replacement:=" ", LookAt:= _
    xlPart, SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
    Selection.NumberFormat = "mmm-yy"
    Rows("6:7").delete Shift:=xlUp
    Range("C4:K4").Select
    With Selection
        .HorizontalAlignment = xlCenter
    End With
    Selection.Merge
    Range("C5:K5").Select
    With Selection
        .HorizontalAlignment = xlCenter
    End With
    Selection.Merge
    Range("C2:K2").Select
    With Selection
        .HorizontalAlignment = xlCenter
    End With
    Selection.Merge
    
    'Delete columns to left of data
    Columns("A:B").Select
    Selection.delete Shift:=xlToLeft
    
    'Delete rows on top of data
    Rows("1:1").Select
    Selection.delete Shift:=xlUp
    
    'Column width defined
    Columns("A:A").ColumnWidth = 50
    Range("B:I").ColumnWidth = 10
    'Range("F:F,I:I").ColumnWidth = 8.5
    
    'Colour Columns
    Range("B11:B310").Interior.ColorIndex = 35
    Range("C11:C310").Interior.Color = 16772300
    Range("D11:D310").Interior.ColorIndex = 6
    Range("E11:E310").Interior.ColorIndex = 15
    Range("F11:F310").Interior.ColorIndex = 15
    Range("G11:G310").Interior.ColorIndex = 6
    Range("H11:H310").Interior.ColorIndex = 15
    Range("I11:I310").Interior.ColorIndex = 15
    
    'Move Project Activity into Header of Body of Report
    Range("A5").Cut
    Range("A7").Select
    ActiveSheet.Paste
    Range("A6").ClearContents
    Application.Goto Reference:="R7C1"
        ActiveCell.Replace What:="Project Activity=**** (", Replacement:=" ", LookAt:= _
    xlPart, SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
        ActiveCell.Replace What:=")", Replacement:=" ", LookAt:=xlPart, SearchOrder _
    :=xlByColumns, MatchCase:=False, SearchFormat:=False, ReplaceFormat:= _
    False
    
    'Copy Column B Header of Body to Column A
    Range("B6:B10").Copy
    Range("A6:A10").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Rows("9:10").delete Shift:=xlUp
    Range("B8:I8").FormulaR1C1 = "$'000"
    Range("A6:I8").Font.Bold = True
    Range("A1").Select
End Sub
Sub FormulaInColumnKForecast()


Dim varFormula


Range("K10").Select


Do While ActiveCell.Offset(0, -1) <> ""
    ActiveCell.FormulaR1C1 = "=RC[-1]+R[1]C[-1]"
    ActiveCell.Offset(1, 0).Select
Loop


End Sub
Sub DeleteExcessHeadingsOtherForecast()


Dim rngStart As Range
Dim rngEnd As Range
Dim dblLastChange As Double
Dim strInvoice As String
Dim n As Long


With ActiveSheet
    'set start row
    Set rngStart = .Range("A10")
    'find end of data in column J
    Set rngEnd = .Range("A" & CStr(Application.Rows.Count)) _
                .End(xlUp)
    'set last change row to last row
    strInvoice = rngEnd.Offset(0, 1).Text


    dblLastChange = rngEnd.Row
    
    'loop through the data starting at last row
    For n = rngEnd.Row To rngStart.Row Step -1
        'test if it has changed
        If .Range("K" & CStr(n)).Text = "16" Then
            'its changed
            'delete row above
            .Rows(CStr(n)).EntireRow.delete
            'save new last change row
            'dblLastChange = n
        End If
    Next n
End With


End Sub
Sub InsertBlankRowsOtherForecast()


Dim rngStart As Range
Dim rngEnd As Range
Dim dblLastChange As Double
Dim n As Single


With ActiveSheet
    'set start row
    Set rngStart = .Range("A11")
    'find end of data in column A
    Set rngEnd = .Range("A" & CStr(Application.Rows.Count)) _
                .End(xlUp)
    'set last change row to last row
    dblLastChange = rngEnd.Row
    
    'loop through the data starting at last row
    For n = rngEnd.Row To rngStart.Row Step -1
        'test if it has changed
        If .Range("J" & CStr(n)).Text = "8" Then
            'its changed
            'insert row below
            .Rows(CStr(n)).Insert
            'save new last change row
            'dblLastChange = n
        End If
    Next n
End With
End Sub
Sub InsCorpServHeading()


Dim foundStaffCosts As Range


    'Find the range with the "Staff Costs"
     With ActiveSheet
        Set foundStaffCosts = Cells.Find(What:="STAFF COSTS", After:=.Cells(9, 1))
        If foundStaffCosts Is Nothing Then
        Else
            'Insert a new row below the row of the foundRange row
            Rows(foundStaffCosts.Row & ":" & foundStaffCosts.Row).Insert


            'Set the found range to be the ActiveCell, this is a quick and easy way of ensuring you aren't repeating find from the top
            foundStaffCosts.Activate
            ActiveCell.Offset(-1, 0).Select
            ActiveCell.FormulaR1C1 = "CORPORATE SERVICES"
        End If
    End With
End Sub
Sub TotalUnderlinePriorForecast()
    Cells.Find(What:="total ", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
    ActiveCell.Offset(-1, 1).Range("A1:H1").Select
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    ActiveCell.Offset(1, -1).Range("A1").Select
End Sub
Sub RemoveOtherGovtExpHeading()
'Find Total Other Govt Expenditure if not there delete Other Govt Expenditureap row


Dim findHeadingRow As Range
Dim findHeadingRowNumber As Long
Dim rFound As Range


    With ActiveSheet
        Set rFound = Cells.Find(What:="TOTAL OTHER GOVT EXPENDITURE", After:=.Cells(9, 1))
        If rFound Is Nothing Then
            With ActiveSheet
                Set findHeadingRow = .Range("A:A").Find(What:="OTHER GOVT EXPENDITURE", LookIn:=xlValues)
            End With
On Error GoTo ErrorSkip
       findHeadingRowNumber = findHeadingRow.Row
    
        Rows(findHeadingRowNumber).delete
ErrorSkip:
        Resume Next
        End If
    End With
End Sub
Sub RemoveCapPurchasesExpHeading()
'Find Total Capital Purchases if not there delete Capital Purchases heading row


Dim findCapPurHeadingRow As Range
Dim findCapPurHeadingRowNumber As Long
Dim rFound As Range


    With ActiveSheet
        Set rFound = Cells.Find(What:="TOTAL CAPITAL PURCHASES", After:=.Cells(9, 1))
        If rFound Is Nothing Then
            With ActiveSheet
                Set findCapPurHeadingRow = .Range("A:A").Find(What:="CAPITAL PURCHASES", LookIn:=xlValues)
            End With
On Error GoTo ErrorSkip
       findCapPurHeadingRowNumber = findCapPurHeadingRow.Row
    
        Rows(findCapPurHeadingRowNumber).delete
ErrorSkip:
        Resume Next
        End If
    End With
End Sub
Sub LandscapeLayoutForecast()
    Range("A1").Select
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$6:$9"
    End With
    ActiveSheet.ResetAllPageBreaks
    ActiveSheet.PageSetup.PrintArea = ""
    With ActiveSheet.PageSetup
        .LeftMargin = Application.InchesToPoints(0.196850393700787)
        .RightMargin = Application.InchesToPoints(0.196850393700787)
        .TopMargin = Application.InchesToPoints(0.393700787401575)
        .BottomMargin = Application.InchesToPoints(0.393700787401575)
        .HeaderMargin = Application.InchesToPoints(0.196850393700787)
        .FooterMargin = Application.InchesToPoints(0.196850393700787)
        .CenterHorizontally = True
        .Orientation = xlLandscape
    End With
End Sub

lyyynnnchy · Sep 10, 2014

This is the loop I was using

Code:

Sub ProcessAll()   Dim sht as worksheet
   for each sht in ActiveWorkbook.Worksheets
      ProcessSheet sht
 Application.Run "PERSONAL.XLSB!AMgmtFirstMacroForecast
   next sht
 End sub

StephenCrump · Sep 11, 2014

Your range references in AMgmtFirstMacroForecast aren't qualified with a sheet name, so ActiveSheet will be used for each iteration.

To illustrate, compare Test1 below (what you've got) and Test2 (what you need).

Code:

Sub Test1()
    
    Dim ws As Worksheet
    
    For Each ws In Worksheets
        Call WriteMessage1
    Next ws
    
End Sub
Sub WriteMessage1()
    
    Range("A1") = "Hello ActiveSheet!"

End Sub
Sub Test2()
    
    Dim ws As Worksheet
    
    For Each ws In Worksheets
        Call WriteMessage2(ws)
    Next ws
    
End Sub
Sub WriteMessage2(ws As Worksheet)
    
    ws.Range("A1") = "Hello to every sheet!"

End Sub

Given that your code uses a lot of .Select and Selection, the quick fix will be:

Code:

For Each sht In ActiveWorkbook.Worksheets
    [COLOR=#ff0000][B]sht.Activate[/B][/COLOR]
    Application.Run "PERSONAL.XLSB!AMgmtFirstMacroForecast"
Next sht

But in the longer term, it's better to avoid using .Select unnecesarily. For example:

Code:

'You can replace this:
Range("A6:I8").Select
With Selection.Interior
    .ThemeColor = xlThemeColorAccent3
End With
'With ...
Range("A6:I8").Interior.ThemeColor = xlThemeColorAccent3

Code:

'And this
Range("J8").Select
Range("J9").FormulaR1C1 = "=COUNTIF(RC[-9]:RC[-1],"""")"
Range("J9").Copy
Range("J10:J310").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'With ...
Range("J9:J310").FormulaR1C1 = "=COUNTIF(RC[-9]:RC[-1],"""")"

Arithos · Sep 11, 2014

When I need to do the same thing in all worksheets I do this thing:

Code:

Sub sheetcount()

Dim shtcount As Variant
Dim i%
shtcount = ThisWorkbook.Worksheets.Count


For i = 1 To shtcount
Sheets(i).Select


************************




DO YOUR MACRO HERE




************************
Next i
End Sub

Looping Macro through all worksheets - Urgent please :(

lyyynnnchy

New Member

Excel Facts

lyyynnnchy

New Member

StephenCrump

MrExcel MVP

Arithos

Well-known Member

Similar threads

Forum statistics

Share this page

Looping Macro through all worksheets - Urgent please :(

lyyynnnchy

New Member

Excel Facts

lyyynnnchy

New Member

StephenCrump

MrExcel MVP

Arithos

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock