Question

我们的公司有36个部门，我们使用总预算工作表来制定预算。部门编号不是连续的，它们的预算都不同。我整理了以下宏，将工作表发送给各个部门。母版中充满了VLOOKUP和其他公式，但各个部门仅收到最终结果，并收到几列有关其更改的信息。他们可以更改未用黄色突出显示的任何数字。该宏仅适用于一个部门，但是当我尝试将其复制到自身以下35倍以便将工作表发送给所有部门时，我收到一条错误消息，指出我的程序太大。我将其分成两半，仍然收到消息！

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

有人可以提供有关如何减小宏大小和/或使其更有效的建议吗？谢谢！

Answer 1

我已经清理了这个问题（至少暂时不让它运行）-但是，我对清理中间部分的工作还不了解。问题无疑是这么长的If语句。

将所有值（而不是所有Or）放入数组，然后使用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

缩小宏的大小

1 个答案: