Question

我有一个很大的excel VBA项目，可以读入多个文件，并生成一个带有多个标签的新excel电子表格。使用每周数据运行时，运行大约需要7分钟。使用月度数据运行时，运行将近18个小时。过去需要花费30多个小时，但多亏了几篇文章，我已经能够对它进行优化了。我试图使项目模块化，我可以选择每次运行时我想运行的程序部分。全程运行需要18个小时。我写了一个日志记录功能来查看花了这么长时间，并且发现程序的一部分需要大约11个小时才能运行。问题是，如果我只选择自己运行的那部分程序，它只需要3分钟就可以运行。在完整运行期间，此部分将在稍后的整个过程中运行，因此在完成此部分之前已经创建了几个选项卡。单独运行时，此部分只创建两个选项卡。我试图弄清楚为什么在自己运行它和在整个过程中运行它之间的处理时间会有这么大的差异。

我添加了相关模块。它可能不是很漂亮，但它确实有效。同样，在整个过程中运行11个小时，在针对相同数据集单独运行时大约需要3分钟。

谢谢，

Sub Upcoming()

Dim Days As Integer
Dim gd_lastrow As Long

'If Logging = True Then
'    logIt ("    Create new sheet")
'End If

Sheets.Add after:=ActiveSheet
ActiveSheet.Name = "Coming Due"
Range("A1").Value = "IS Code"
Range("B1").Value = "Cage"
Range("C1").Value = "Contractor"
Range("D1").Value = "Contract Number"
Range("E1").Value = "Job #"
Range("F1").Value = "CLIN"
Range("G1").Value = "Due Date"
Range("H1").Value = "RDF"
Range("I1").Value = "Product"
Range("J1").Value = "Qty"
Range("K1").Value = "CA"
Rows("1:1").WrapText = True
Columns("B:B").ColumnWidth = 8
Columns("C:C").ColumnWidth = 46
Columns("D:D").ColumnWidth = 21
Columns("G:G").ColumnWidth = 18
Columns("H:H").ColumnWidth = 18
Columns("I:I").ColumnWidth = 15
Columns("F:F").ColumnWidth = 10
Columns("G:G").ColumnWidth = 21
Columns("K:K").ColumnWidth = 18

Columns("E:F").NumberFormat = "0000"
Columns("E:F").HorizontalAlignment = xlRight
Columns("G:H").NumberFormat = "[$-409]mmmm d, yyyy;@"

up_curline = 2
up_IS = ""

'Sheets("GD").Select
'gd_lastrow = (ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row) - 1
gd_lastrow = (Sheets("GD").UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row) - 1

If myFileExists(myPath & "\GD.xlsx") Then
    If Logging = True Then
        logIt ("    Prep the GD for vLookup")
    End If
    Sheets("GD").Select
    If Range("BF6").Value = "" Then
        For i = 6 To gd_lastrow
            Range("BF" & i).Value = Range("F" & i).Value & Range("G" & i).Value & Range("T" & i)
            Range("BG" & i).Value = Abs(Range("P" & i))
            Range("BH" & i).Value = Range("F" & i).Value & Range("G" & i).Value & Range("U" & i)
            Range("BI" & i).Value = Abs(Range("P" & i))
        Next i
    End If
End If

'If Logging = True Then
'    logIt ("    Get upcoming schedules or RDFs")
'End If

Sheets("DWR").Select
up_lastRow = (ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row) - 1

For i = 2 To up_lastRow  'Get upcoming RDF's
    Sheets("DWR").Select
    If Not IsError(Application.Match(Range("C" & i), Worksheets("CAR").Range("C:C"), 0)) Then  'Only get RDF's for the IS's in the CAR
        If Not IsError(Application.Match(Range("G" & i), Worksheets("CAR").Range("H:H"), 0)) Then  'Only get RDFs for active contracts
            If ((Range("K" & i) >= Now()) And (Range("K" & i) <= Now() + 90) And (Range("AE" & i) = "")) Or _
               ((Range("Q" & i) >= Now()) And (Range("Q" & i) <= Now() + 90) And (Range("AE" & i) = "")) Or _
               ((Range("AE" & i) >= Now()) And (Range("AE" & i) <= Now() + 90)) Then
                Worksheets("Coming Due").Range("A" & up_curline) = Range("C" & i)  'IS
                Worksheets("Coming Due").Range("B" & up_curline) = Range("E" & i)  ' Cage
                Worksheets("Coming Due").Range("C" & up_curline) = Range("D" & i)  'Contractor
                Worksheets("Coming Due").Range("D" & up_curline) = Range("G" & i)  ' Contract #
                Worksheets("Coming Due").Range("F" & up_curline) = Range("J" & i)  ' CLIN
                If (Range("K" & i) = 0) Then
                    Worksheets("Coming Due").Range("G" & up_curline) = Range("Q" & i)
                    Sheets("Coming Due").Select
                    Range("H" & up_curline).Select
                    'Sheets("Coming Due").Range("H" & up_curline).ThemeColor = xlThemeColorDark1
                    'Sheets("Coming Due").Range("H" & up_curline).TintAndShade = -0.249977111117893
                    With Selection.Interior
                        .Pattern = xlSolid
                        .PatternColorIndex = xlAutomatic
                        .ThemeColor = xlThemeColorDark1
                        .TintAndShade = -0.249977111117893
                        .PatternTintAndShade = 0
                    End With
                    Sheets("DWR").Select
                Else
                    Worksheets("Coming Due").Range("G" & up_curline) = Range("K" & i)  ' Due Date
                End If
                If Worksheets("Coming Due").Range("H" & up_curline) <> "Service CLIN" Then
                    Worksheets("Coming Due").Range("H" & up_curline) = Range("AE" & i)  ' RDF
                End If
                If ((Worksheets("Coming Due").Range("H" & up_curline) = "") Or (Worksheets("Coming Due").Range("H" & up_curline)) = "Service CLIN") Then
                    Worksheets("Coming Due").Range("G" & up_curline).Style = "Neutral"
                Else
                    Worksheets("Coming Due").Range("H" & up_curline).Style = "Neutral"
                End If
                'Worksheets("Coming Due").Range("I" & up_curline) = Range("V" & i) ' Item
                If ((Range("N" & i) > 0) And (Range("N" & i) = Range("O" & i))) Then
                    Worksheets("Coming Due").Range("J" & up_curline) = "Shipped"
                Else
                    'Worksheets("Coming Due").Range("J" & up_curline) = Range("N" & i) - Range("O" & i)  ' Qty
                    On Error Resume Next
                    Err.Clear
                    Worksheets("Coming Due").Range("J" & up_curline) = Application.WorksheetFunction.VLookup(Worksheets("DWR").Range("G" & i).Value & format(Worksheets("DWR").Range("J" & i), "0000") & Worksheets("DWR").Range("K" & i), Worksheets("GD").Range("BF6:BG" & gd_lastrow), 2, 0)
                    If Err.Number <> 0 Then
                        Err.Clear
                        Worksheets("Coming Due").Range("J" & up_curline) = Application.WorksheetFunction.VLookup(Worksheets("DWR").Range("G" & i).Value & Worksheets("DWR").Range("J" & i) & Worksheets("DWR").Range("K" & i), Worksheets("GD").Range("BF6:BG" & gd_lastrow), 2, 0)
                        If Err.Number <> 0 Then
                            Err.Clear
                            Worksheets("Coming Due").Range("J" & up_curline) = Application.WorksheetFunction.VLookup(Worksheets("DWR").Range("G" & i).Value & format(Worksheets("DWR").Range("J" & i), "0000") & Worksheets("DWR").Range("K" & i), Worksheets("GD").Range("BH6:BI" & gd_lastrow), 2, 0)
                            If Err.Number <> 0 Then
                                Err.Clear
                                Worksheets("Coming Due").Range("J" & up_curline) = Application.WorksheetFunction.VLookup(Worksheets("DWR").Range("G" & i).Value & Worksheets("DWR").Range("J" & i) & Worksheets("DWR").Range("K" & i), Worksheets("GD").Range("BH6:BI" & gd_lastrow), 2, 0)
                                If Err.Number <> 0 Then
                                    If Logging = True Then
                                        logIt ("            VlookUp Still Not Found")
                                        logIt ("            " & Err.Number & ": " & Err.Description)
                                        logIt ("            i = " & i)
                                        logIt ("            Contract = " & Worksheets("DWR").Range("G" & i).Value)
                                        logIt ("            CLIN = " & format(Worksheets("DWR").Range("J" & i), "0000"))
                                        logIt ("            Schedule Date = " & Worksheets("DWR").Range("K" & i))
                                        logIt ("            Lookup Value = " & Worksheets("DWR").Range("G" & i).Value & format(Worksheets("DWR").Range("J" & i), "0000") & Worksheets("DWR").Range("K" & i))
                                    End If
                                End If
                            End If
                        End If
                    End If
                    On Error GoTo 0
                End If
                For o = 0 To 2000
                    If CDRLdata(o).contract = Worksheets("Coming Due").Range("D" & up_curline) Then
                        Worksheets("Coming Due").Range("E" & up_curline) = CDRLdata(o).job
                        Worksheets("Coming Due").Range("I" & up_curline) = CDRLdata(o).Product
                        Exit For
                    End If
                Next o
                up_curline = up_curline + 1
            End If
        End If
    End If
Next i

Sheets("Coming Due").Select
up_lastRow = (ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row) - 1

'If Logging = True Then
'    logIt ("    Get service CLIN data")
'End If

Sheets("GD").Select  'Get service CLINs qty due
gd_lastrow = (ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row) - 1

For j = 2 To up_lastRow
    If Worksheets("Coming Due").Range("J" & j) = 0 Then
        For i = 6 To gd_lastrow
            If ((Range("F" & i) = Worksheets("Coming Due").Range("D" & j)) And (Range("G" & i) = Worksheets("Coming Due").Range("F" & j)) And (Range("W" & i) = Worksheets("Coming Due").Range("G" & j))) Then
                If ((Range("H" & i) > 0) And (Range("H" & i) = Range("I" & i))) Then
                    Worksheets("Coming Due").Range("J" & j) = "Shipped"
                Else
                    Worksheets("Coming Due").Range("J" & j) = Range("H" & i) - Range("I" & i)
                End If
            End If
        Next i
    End If
Next j

For j = 2 To up_lastRow
    If Worksheets("Coming Due").Range("J" & j) = "Shipped" Then
        For i = 6 To gd_lastrow
            If ((Range("F" & i) = Worksheets("Coming Due").Range("D" & j)) And (Range("G" & i) = Worksheets("Coming Due").Range("F" & j)) And (Range("U" & i) = Worksheets("Coming Due").Range("G" & j))) Then
                If ((Range("N" & i) > 0) And (Range("N" & i) = Range("O" & i))) Then
                    Worksheets("Coming Due").Range("J" & j) = "Shipped"
                Else
                    Worksheets("Coming Due").Range("J" & j) = Range("N" & i) - Range("O" & i)
                End If
            End If
        Next i
    End If
Next j

' Add any comments

'If Logging = True Then
'    logIt ("    Add comments to the list")
'End If

Dim tCLIN As String

Sheets("Coming Due").Select
commenttext = ""

cd_lastrow = (ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row) - 1

For r = 2 To cd_lastrow
    For p = 0 To 2000
        If CDRLdata(p).company = "" Then
            Exit For
        End If

        ' Contract level

        If ((CDRLdata(p).contract = Worksheets("Coming Due").Range("D" & r)) And (CDRLdata(p).CoNotes <> "")) Then
            commenttext = CDRLdata(p).contract & ": " & CDRLdata(p).CoNotes
            temp2 = "D" & r
            Set mycomment = Range(temp2).Comment
            If mycomment Is Nothing Then
                Range(temp2).AddComment
                Range(temp2).Comment.Visible = False
                Range(temp2).Comment.Text commenttext
                Range(temp2).Comment.Shape.TextFrame.AutoSize = True
            End If
        End If

        ' CLIN Level

        If CDRLdata(p).contract = Worksheets("Coming Due").Range("D" & r) Then
            If Len(Worksheets("Coming Due").Range("F" & r)) = 1 Then
                tCLIN = "000" & Worksheets("Coming Due").Range("F" & r)
            Else
                If Len(Worksheets("Coming Due").Range("F" & r)) = 2 Then
                    tCLIN = "00" & Worksheets("Coming Due").Range("F" & r)
                Else
                    If Len(Worksheets("Coming Due").Range("F" & r)) = 3 Then
                        tCLIN = "0" & Worksheets("Coming Due").Range("F" & r)
                    Else
                        tCLIN = Worksheets("Coming Due").Range("F" & r)
                    End If
                End If
            End If

            If ((CDRLdata(p).CLIN = tCLIN) And (tCLIN <> "")) Then
                If CDRLdata(p).CdNotes <> "" Then
                    commenttext = CDRLdata(p).contract & " CLIN " & CDRLdata(p).CLIN & ": "
                    If CDRLdata(p).di <> "" Then
                        commenttext = commenttext & CDRLdata(p).di & " "
                    End If
                    commenttext = commenttext & CDRLdata(p).CdNotes
                    For q = p + 1 To 2000
                        If ((CDRLdata(q).contract = Worksheets("Coming Due").Range("D" & r)) And (CDRLdata(q).CLIN = Worksheets("Coming Due").Range("F" & r)) And (CDRLdata(q).CdNotes <> "")) Then
                            commenttext = commenttext & "  " & " CLIN " & CDRLdata(q).CLIN & ": "
                            If CDRLdata(q).di <> "" Then
                                commenttext = commenttext & CDRLdata(q).di & " "
                            End If
                            commenttext = commenttext & CDRLdata(q).CdNotes
                        End If
                    Next q
                    temp2 = "F" & r
                    Set mycomment = Range(temp2).Comment
                    If mycomment Is Nothing Then
                        Range(temp2).AddComment
                        Range(temp2).Comment.Visible = False
                        Range(temp2).Comment.Text commenttext
                        Range(temp2).Comment.Shape.TextFrame.AutoSize = True
                    End If
                    Exit For
                End If
            End If
        End If
    Next p
Next r

'If Logging = True Then
'    logIt ("    Format comments")
'End If

Comments_Tom

'If Logging = True Then
'    logIt ("    Sort table by IS, Cage, Due date, Contract and CLIN")
'End If

Sheets("Coming Due").Select

up_lastRow = (ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row) - 1

For i = 2 To up_lastRow
    If Range("H" & i) = "" Then
        Range("M" & i) = Range("G" & i)
    Else
        If Range("H" & i) = "Service CLIN" Then
            Range("M" & i) = Range("G" & i)
        Else
            Range("M" & i) = Range("H" & i)
        End If
    End If
Next

For i = 2 To up_lastRow
    For p = 0 To 2000
        ' Get CA Name
        If CDRLdata(p).contract = Worksheets("Coming Due").Range("D" & i) Then
            If CDRLdata(p).Position1 = "Contract Administrator" Then
                Range("K" & i) = CDRLdata(p).Name1
            Else
                If CDRLdata(p).Position2 = "Contract Administrator" Then
                    Range("K" & i) = CDRLdata(p).Name2
                Else
                    If CDRLdata(p).Position3 = "Contract Administrator" Then
                        Range("K" & i) = CDRLdata(p).Name3
                    End If
                End If
            End If
            Exit For
        End If
    Next p
Next i

'sort by IS, Cage, Due date, Contract, CLIN

Range("A2:M" & up_lastRow).Select
ActiveWorkbook.Worksheets("Coming Due").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Coming Due").Sort.SortFields.Add Key:=Range( _
    "A2:A" & up_lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortNormal
ActiveWorkbook.Worksheets("Coming Due").Sort.SortFields.Add Key:=Range( _
    "B2:B" & up_lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortTextAsNumbers
ActiveWorkbook.Worksheets("Coming Due").Sort.SortFields.Add Key:=Range( _
    "M2:M" & up_lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortNormal
ActiveWorkbook.Worksheets("Coming Due").Sort.SortFields.Add Key:=Range( _
    "D2:D" & up_lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortNormal
ActiveWorkbook.Worksheets("Coming Due").Sort.SortFields.Add Key:=Range( _
    "F2:F" & up_lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortNormal
With ActiveWorkbook.Worksheets("Coming Due").Sort
    .SetRange Range("A1:M" & up_lastRow)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

ActiveWorkbook.Save

' enter 30/60/90 day group headers

If Logging = True Then
    logIt ("    Enter 30/60/90 day headers")
End If

Sheets("Coming Due").Select
Range("A2").Select

up_curline = 2
up_IS = Range("A2")
up_cage = Range("B2")
up_Contract = Range("C2")
up_Due = Range("G2")
up_RDF = Range("H2")
up_Due = 0
up_RDF = 0

Rows("2:4").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
up_lastRow = up_lastRow + 3
up_curline = up_curline + 3

If ((Range("G" & up_curline) <= Now() + 30) And (Range("H" & up_curline) = "")) Then
    Range("D" & up_curline - 2).Value = "Due within 30 days"
    Days = 30
Else
    If ((Range("G" & up_curline) <= Now() + 60) And (Range("H" & up_curline) = "")) Then
        Range("D" & up_curline - 2).Value = "Due within 60 days"
        Days = 60
    Else
        If Range("H" & up_curline) = "" Then
            Range("D" & up_curline - 2).Value = "Due within 90 days"
            Days = 90
        End If
    End If
End If
If (Range("H" & up_curline) <> "") Then
    If Range("H" & up_curline) <= Now() + 30 Then
        Range("D" & up_curline - 2).Value = "Due within 30 days"
        Days = 30
    Else
        If Range("H" & up_curline) <= Now() + 60 Then
            Range("D" & up_curline - 2).Value = "Due within 60 days"
            Days = 60
        Else
            Range("D" & up_curline - 2).Value = "Due within 90 days"
            Days = 90
        End If
    End If
End If

i = up_curline
Do Until IsEmpty(Cells(i, 1))
    If Range("B" & i) <> up_cage Then
        up_cage = Range("B" & i)
        Rows(i & ":" & i + 2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        up_lastRow = up_lastRow + 3
        i = i + 3
        If ((Range("G" & i) <= Now() + 30) And ((Range("H" & i) = "")) Or _
            (((Range("H" & i) <> "")) And (Range("H" & i) <= Now() + 30))) Then
            Range("D" & i - 2).Value = "Due within 30 days"
            Days = 30
        Else
            If ((Range("G" & i) <= Now() + 60) And ((Range("H" & i) = "")) Or _
                (((Range("H" & i) <> "")) And (Range("H" & i) <= Now() + 60))) Then
                Range("D" & i - 2).Value = "Due within 60 days"
                Days = 60
            Else
                Range("D" & i - 2).Value = "Due within 90 days"
                Days = 90
            End If
        End If
    End If
    If (Days = 30) And _
       (((Range("G" & i) > Now() + 30) And (Range("G" & i) <= Now + 60) And (Range("H" & i) = "")) Or _
       ((Range("H" & i) > Now() + 30) And (Range("H" & i) <= Now + 60) And (Range("H" & i) <> ""))) Then
        Days = 60
        Rows(i & ":" & i + 2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        up_lastRow = up_lastRow + 3
        i = i + 3
        Range("D" & i - 2).Value = "Due within 60 days"
    End If
    If (Days = 30) And _
       (((Range("G" & i) > Now() + 60) And (Range("G" & i) <= Now + 90) And (Range("H" & i) = "")) Or _
       ((Range("H" & i) > Now() + 60) And (Range("H" & i) <= Now + 90) And (Range("H" & i) <> ""))) Then
        Days = 90
        Rows(i & ":" & i + 2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        up_lastRow = up_lastRow + 3
        i = i + 3
        Range("D" & i - 2).Value = "Due within 90 days"
    End If
    If (Days = 60) And _
       (((Range("G" & i) > Now() + 60) And (Range("G" & i) <= Now + 90) And (Range("H" & i) = "")) Or _
       ((Range("H" & i) > Now() + 60) And (Range("H" & i) <= Now + 90) And (Range("H" & i) <> ""))) Then
        Days = 90
        Rows(i & ":" & i + 2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        up_lastRow = up_lastRow + 3
        i = i + 3
        Range("D" & i - 2).Value = "Due within 90 days"
    End If
    i = i + 1
Loop

Columns("M:M").Delete

For i = 5 To up_lastRow
    If Left(Range("D" & i), 10) = "Due within" Then
        Range("G" & i - 1 & ":H" & i + 1).Style = "Normal"
    End If
Next

Sheets("Coming Due").Select
ActiveCell.ClearComments
Range("A2").Select
ActiveWindow.FreezePanes = True
ActiveSheet.Name = "30-60-90 By Date"
up_lastRow = (ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row) - 1
Range("A1:K" & up_lastRow).Borders.LineStyle = xlContinuous

ActiveWorkbook.Save

' Create the 30-60-90 by Contract Tab

If Logging = True Then
    logIt ("Begin Upcoming By Contract")
End If

Dim curCage As String
Dim curContract As String

Range("A1:K" & up_lastRow).Select
Selection.Copy
Sheets.Add
ActiveSheet.Name = "30-60-90 By Contract"
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Application.CutCopyMode = False
If Logging = True Then
    logIt ("    Begin Sorting By Contract")
End If
ActiveWorkbook.Worksheets("30-60-90 By Contract").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("30-60-90 By Contract").Sort.SortFields.Add Key:= _
    Range("B5:B" & up_lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
    :=xlSortNormal
ActiveWorkbook.Worksheets("30-60-90 By Contract").Sort.SortFields.Add Key:= _
    Range("D5:D" & up_lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
    :=xlSortNormal
ActiveWorkbook.Worksheets("30-60-90 By Contract").Sort.SortFields.Add Key:= _
    Range("G5:G" & up_lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
    :=xlSortNormal
With ActiveWorkbook.Worksheets("30-60-90 By Contract").Sort
    .SetRange Range("A5:K" & up_lastRow)
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
Rows("3:4").Delete Shift:=xlUp
If Logging = True Then
    logIt ("    Begin Deleting Blank Rows")
End If
For i = up_lastRow - 2 To 1 Step -1
    If Range("A" & i).Value = "" Then
        Rows(i & ":" & i).Delete Shift:=xlUp
    Else
        up_lastRow = i
        Exit For
    End If
    If ((i Mod 200) = 0) Then
        If Logging = True Then
            logIt ("    Line =" & i)
        End If
    End If
Next i
Range("A2").Select
ActiveWindow.FreezePanes = True
curCage = Range("B3").Value
curContract = Range("D3").Value
j = 4
If Logging = True Then
    logIt ("    Begin Looking For New CAGE or Contract Number")
End If

While Range("A" & j).Value <> ""
    If Range("B" & j).Value <> curCage Then
        curCage = Range("B" & j).Value
        curContract = Range("D" & j).Value
        Rows(j & ":" & j + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        j = j + 2
    End If
    If Range("D" & j).Value <> curContract Then
        curContract = Range("D" & j).Value
        Rows(j & ":" & j).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        j = j + 1
    End If
    j = j + 1
    If ((j Mod 200) = 0) Then
        If Logging = True Then
            logIt ("    Line =" & j)
        End If
    End If
Wend
End Sub

Answer 1

VBA有点像Java，它运行在JVM上并不是真正运行它的CPU。例如，在PS3 / PC上模拟Mac而不是使用真实设备时（考虑到非常慢），请考虑游戏速度。

什么意思VBA已经非常缓慢，现在你的代码确实在Excel上运行，这将进一步减慢一切，因为它会等待Excel查看/更新。

我的选择是使用Qt和QtXlsxWriter重写您的代码。虽然从VBA更改为C++对我来说是一个很好的步骤，但Qt库更清楚地理解为VBA。

另一个选择是提供你的代码，以便我们看到问题是什么，但看起来这不是一个选项; - ）

没有代码我认为它与VBA等待Excel更新

有关

Answer 2

我几乎解决了我的问题，但仍然没有回答我的问题。我现在已经在不到4个小时内完成了每月运行，并且仍然可以看到可以进行其他优化的位置。我主要做了三个改变。首先，我在模块开头花了这么长时间放入Application.Calculation = xlCalculationManual，并在模块结束时将其设置为自动。这将11小时减少到大约4到5个小时。我已经阅读了很多关于优化的内容，但上面的评论是我第一次听说过这个。接下来，我将此模块移动到运行的开始。回想一下，在完整运行的后期运行该模块需要11个小时，但是当单独运行时，它只需要大约三分钟。当作为第一个模块运行时，在完整运行中它只需要三到四分钟。最后，我重写了模块以使用2D数组，而不是在工作表中插入和删除行和列。该模块现在大约需要1分钟。从11 +小时到1分钟我觉得很好。但问题仍然存在。为什么从运行的后期开始将模块移动到第一个引起如此大的差异，特别是当recalc设置为手动时。是内存管理吗？是吗？？？？？我不知道，但我对结果非常满意。

为什么VBA运行速度很慢？

2 个答案: