Reducing size of a macro

Question

Our company has 36 departments and we use a master budgeting worksheet to develop the budget. The department numbers are not sequential and their budgets are all different. I put together the following macro to send the worksheets to the individual departments. The master is full of VLOOKUPs and other formulae, but the individual departments receive only the final results and a couple of columns for their changes. They can make changes to any number that is not highlighted in yellow. The macro works perfectly for only one department, but when I tried to copy it 35 times below itself so that I could send a worksheet to all departments, I received an error message that said my procedure was too large. I divided it in half and I still received the message!

Sub Macro1()
'
' Macro1 Macro
'' Prepares O&M budget Worksheet for uploading

' Dim sourceSheet as Worksheet
  Workbooks.Open Filename:="F:\Rick\2020 Budget\2020 O&M Budget.xlsx"
  Set sourcesheet = Worksheets("Dept Detail-O&M Book")
  sourcesheet.Activate

' Dim N As Long
' Dim T As Long
' Dim LastRow As Long
lastrow = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row

Dim i As Long, Total As Long
Dim cell As Range
Application.EnableEvents = False

'
Application.Goto Reference:="Dept_01"
Selection.Copy
Workbooks.Open Filename:="Q:\O&M\Departmental Budgets\Dept 1 MOEC.xlsx"
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
    xlNone, SkipBlanks:=False, Transpose:=False
ThisWorkbook.Activate
Application.CutCopyMode = False
Selection.Copy
Windows("Dept 1 MOEC.xlsx").Activate
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("R1").Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Application.CutCopyMode = False
n = Cells(Rows.Count, "R").End(xlUp).Row
Cells(n, "R").Formula = "=SUM(R1:R" & n - 1 & ")"
activecell.Select
Selection.Copy
activecell.Offset(0, 2).Select
ActiveSheet.Paste
Selection.Copy
activecell.Offset(0, 2).Select
ActiveSheet.Paste
Range("X9").Select
activecell.FormulaR1C1 = "=iferror(+RC[-2]/RC[-10],0)"
Range("X9").Select
T = Cells(Rows.Count, "X").End(xlUp).Row
Selection.AutoFill Destination:=Range("x9:x" & T)

With ActiveSheet
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
Application.EnableEvents = False
For i = lastrow To 1 Step -1
    If Range("B" & i).Value = "1010" Or _
        Range("B" & i).Value = "1020" Or _
        Range("B" & i).Value = "2172" Or _
        Range("B" & i).Value = "2190" Or _
        Range("B" & i).Value = "2200" Or _
        Range("B" & i).Value = "2290" Or _
        Range("B" & i).Value = "4020" Or _
        Range("B" & i).Value = "4050" Or _
        Range("B" & i).Value = "4060" Or _
        Range("B" & i).Value = "4070" Or _
        Range("B" & i).Value = "4090" Or _
        Range("B" & i).Value = "4100" Or _
        Range("B" & i).Value = "4110" Or _
        Range("B" & i).Value = "4509" Or _
        Range("B" & i).Value = "4510" Or _
        Range("B" & i).Value = "4600" Or _
        Range("B" & i).Value = "4610" Or _
        Range("B" & i).Value = "4700" Or _
        Range("B" & i).Value = "5710" Or _
        Range("B" & i).Value = "5721" Or _
        Range("B" & i).Value = "5723" Or _
        Range("B" & i).Value = "5725" Or _
        Range("B" & i).Value = "5729" Or _
        Range("B" & i).Value = "5730" Or _
        Range("B" & i).Value = "5731" Then
        .Range("R" & i).Interior.Color = RGB(255, 255, 0)
        .Range("T" & i).Interior.Color = RGB(255, 255, 0)
    End If
Next i
Application.EnableEvents = True
End With
With ActiveSheet
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
Application.EnableEvents = False
For i = lastrow To 1 Step -1
    If Range("B" & i).Value = "5721" Or _
        Range("B" & i).Value = "9000" Or _
        Range("B" & i).Value = "9005" Or _
        Range("B" & i).Value = "9010" Or _
        Range("B" & i).Value = "9030" Then
        .Range("R" & i).Interior.Color = RGB(255, 255, 0)
        .Range("T" & i).Interior.Color = RGB(255, 255, 0)
    End If
Next i
Application.EnableEvents = True
End With
Range("A1").Select
ActiveWorkbook.Save
ActiveWindow.Close
End Sub

Could someone offer suggestions on how to reduce the size of the macro and/or make it more efficient? Thanks!

[Avoiding Activate and Select](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba) would be a good start. If the code is the same for each department, you may want to consider passing the department to a function — cybernetic.nomad, Dec 28 '18 at 16:56
You need to re-write that `If` statement. Perhaps, add the values it could be to an array, then loop through that array to check the value. Or use `Select Case`. Or, actually, that part could be set with Conditional Formatting, no? Why VBA for that aspect? — BruceWayne, Dec 28 '18 at 17:09

score 0 · Answer 1 · answered Dec 28 '18 at 17:13

I took a shot at cleaning this up (at least to make it run, for now) - I don't know enough about what you're doing to clean up that mid section, though. The problem undoubtedly was that long If statement.

Instead of all the Ors, put all your values in an array then test against that array with IsError:

Option Explicit
Sub Macro1()

    Dim valuearr As Variant
    Dim cell As Range
    Dim sourcesheet As Worksheet
    Dim lastrow As Long, i As Long, n As Long

    Workbooks.Open Filename:="F:\Rick\2020 Budget\2020 O&M Budget.xlsx"
    Set sourcesheet = Worksheets("Dept Detail-O&M Book")
    sourcesheet.Activate

    lastrow = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row

    Application.EnableEvents = False

    'This section needs to be cleaned up...

    Application.Goto Reference:="Dept_01"
    Selection.Copy
    Workbooks.Open Filename:="Q:\O&M\Departmental Budgets\Dept 1 MOEC.xlsx"
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    ThisWorkbook.Activate
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Dept 1 MOEC.xlsx").Activate
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("R1").Select
    Selection.End(xlDown).Select
    Application.CutCopyMode = False
    n = Cells(Rows.Count, "R").End(xlUp).Row
    Cells(n, "R").Formula = "=SUM(R1:R" & n - 1 & ")"
    ActiveCell.Copy
    ActiveCell.Offset(0, 2).Paste
    Selection.Offset(0, 2).Select
    ActiveSheet.Paste
    Range("X9").FormulaR1C1 = "=iferror(+RC[-2]/RC[-10],0)"
    Range("X9").AutoFill Destination:=Range("x9:x" & Cells(Rows.Count, "X").End(xlUp).Row)

    With ActiveSheet
        lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row

        valuearr = Array(1010, 1020, 2172, 2190, 2200, 2290, 4020, 4050, 4060, 4070, 4090, 4100, 4110, 4509, 4510, 4600, 4610, 4700, 5710, 5721, 5723, 5725, 5729, 5730, 5731, 9000, 9005, 9010, 9030)

        For i = lastrow To 1 Step -1
            If IsError(Application.Match(Range("B" & i).Value, valuearr, 0)) Then
                .Range("R" & i).Interior.Color = RGB(255, 255, 0)
                .Range("T" & i).Interior.Color = RGB(255, 255, 0)
            End If
        Next i

    End With

    Application.EnableEvents = True
    ActiveWorkbook.Save
    ActiveWindow.Close

End Sub

Reducing size of a macro

1 Answers1