Reducing size of a macro - excel

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!

Answer 1

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