vba - 随着报告的增长，代码变慢

Question

我在日常工作中一直在运行此代码以了解我的订单和运输情况，该代码在指定位置打开电子表格并返回以下内容、发票编号、公司名称、运输日期和总订单值(value)并放置将它们放入一个主电子表格中。

我去年开始使用它，过去只需要不到 3 分钟的时间来运行大约 400-500 个电子表格来收集数据。现在我今年有类似数量的数据要运行，但报告需要几个小时!

我没有更改我的报告，数据是来自同一模板的相同数据，只是位于不同文件夹中，但位于同一父文件夹下同一驱动器上的同一位置。

我不认为是位置的变化减慢了它的速度。

我在下面包含了我的代码副本，大部分代码下都有注释来解释每一行的功能，任何人都可以看到代码的任何问题或建议任何改进吗？

Sub Invoice_Records()
    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim FileExt As String
    Dim CellValue As Range
    Dim Text As String
    Dim Text2 As String
    Dim Text3 As String
    Dim Total As Range
    Dim filecountB As String
    Dim i As String
    Dim ws As Worksheet
    Dim Invoice_Count As Integer

    Set ws = Worksheets("Admin2")

    'This part clears all columns, otherwise if you were on line 10 last time you ran the code,
    'and then you deleted a commercial invoice it would only update up to line 9 but the legacy values of line 10 would still show
    ws.Columns(2).EntireColumn.Clear
    ws.Columns(3).EntireColumn.Clear
    ws.Columns(4).EntireColumn.Clear
    ws.Columns(5).EntireColumn.Clear
    ws.Columns(6).EntireColumn.Clear
    ws.Columns(7).EntireColumn.Clear

    'Create an instance of the FileSystemObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    'Get the folder object
    Set objFolder = objFSO.GetFolder("C:\Users\king_matthew\Documents\ELINV 2018")
    filecountB = objFolder.Files.Count
    i = 1
    'loops through each file in the directory and prints their names and path
    For Each objFile In objFolder.Files
        'print file name
        ws.Cells(i + 1, 2) = objFile.Name
        'print file path
        ws.Cells(i + 1, 3).Select
        ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=objFile.Path, TextToDisplay:=objFile.Path
        'Get the file extension
        FileExt = Right(objFile.Name, Len(objFile.Name) - InStrRev(objFile.Name, "."))
        'Paste file extension in column D
        ws.Cells(i + 1, 4) = FileExt
        If FileExt = "xlsm" Then
            'This line stops the excel documents opening on your screen they just open in the background meaning your screen does not flicker
            Application.ScreenUpdating = False
            Application.StatusBar = True
            Application.StatusBar = "Currently processing item " + i + " out of " + filecountB
            'This opens the documents

            Workbooks.Open Filename:=objFile.Path
            'Tells VBA what you are looking for
            Text = "Total Invoice Value"
            'Find text, defined in line above
            Set Match = ActiveSheet.Cells.Find(Text)
            'Get the value of the cell next to cell found above
            findoffset = Match.Offset(, 1).Value
            'Paste this value in to column F
            ws.Cells(i + 1, 6) = findoffset
            'Tells VBA what else to look for
            Text2 = "Order No:"
            'Find Text2, defined in line above
            Set Index = ActiveSheet.Cells.Find(Text2)
            'If "Order No:" cant be found then do below if it is found skip to ELSE
            If Index Is Nothing Then
                'Tells VBA what else to look for
                Text3 = "Date:"
                'Find text, defined in line above
                Set Match2 = ActiveSheet.Cells.Find(Text3)
                'Get the value of the cell next to cell found above
                findoffset = Match2.Offset(, 1).Value
                'Close the workbook
                ActiveWorkbook.Close
                'Turn screen updating on so that you can see the values being updated
                Application.ScreenUpdating = True
                'Paste this value in to column F
                ws.Cells(i + 1, 5) = findoffset
                'Go onto the next file
                i = i + 1
            Else
                'Paste the "Order No:" in column G
                ws.Cells(i + 1, 7) = Index
                'Tells VBA what else to look for
                Text3 = "Date:"
                'Find text, defined in line above
                Set Match2 = ActiveSheet.Cells.Find(Text3)
                'Get the value of the cell next to cell found above
                findoffset = Match2.Offset(, 1).Value
                'Close the workbook
                ActiveWorkbook.Close

                'Paste this value in to column F
                ws.Cells(i + 1, 5) = findoffset
                'Go onto the next file
                i = i + 1
            End If
        Else
            'If file extension is anything other than XLSM then leave the date blank
            ws.Cells(i + 1, 5) = ""
            'Go onto the next file
            i = i + 1
        End If
    Next objFile
    'Turn screen updating on so that you can see the values being updated
    Application.ScreenUpdating = True

    Application.StatusBar = False

    Call FindingLastRow

End Sub

Sub FindingLastRow()

    Dim ws As Worksheet
    Dim ws2 As Worksheet
    Dim lastRow As Long

    Set ws = Worksheets("Admin2")



    'Rows.count returns the last row of the worksheet (which in Excel 2007 is 1,048,576); Cells(Rows.count, "A")
    'returns the cell A1048576, ie. last cell in column A, and the code starts from this cell moving upwards;
    'the code is bascially executing Range("A1048576").End(xlUp), and Range("A1048576").End(xlUp).Row finally returns the last row number.
    lastRow = ws.Cells(Rows.Count, "B").End(xlUp).Row

    ws.Range("Row_Number").Value = lastRow

End Sub

Answer 1

好的，所以我更改了一些内容并删除了一些不必要的代码。这是我的“变更日志”:

已注释掉对 FindingLastRow 的调用因为它目前什么都不做

移动了 'Dims' 以便于阅读

删除了未使用的变量

为临时工作簿添加了变量

我这样做是为了避免使用 ActiveSheet这将减慢代码

注意:设置 wsTemp 的行可能无法正常工作，如果失败请告诉我

对列进行分组。清除您调用的电话

更改了 i 的起始值为简单起见，改为 2

添加范围变量以捕获 Range.Find("..")结果

已移动 Application.ScreenUpdating在循环外调用

没有理由让它在循环内部如此频繁地切换

添加切换到 .Calculation和 .EnableEvents有可能进一步加快程序

它们的行为类似于 .ScreenUpdating通过抑制 excel 并通过仅关注某些操作来加速

删除了 .select对于超链接

喜欢调用Activesheet , 调用.select也会减慢代码速度

StatusBar 的字符串连接使用 &而不是 +

改变了 if语句用于清除重复代码

有几次你在 if 中重复代码。 s 当你可以在他们之后立即做

重新排序值粘贴以匹配它们粘贴的列(即 C、D、E、F、G )

使用 .cells(r,c) 调用单元格时你实际上可以只使用列字符串，所以为了简单起见我这样做了

注意:您的评论说“日期”将放在 F 列中，但您的实际代码将它放在 E 列中，所以我选择使用 E

开始使用 .value2和 .value访问/粘贴文本到单元格时

注意:在“订单号”中添加了偏移量以匹配您的其他搜索(看起来像是疏忽)

我觉得就这样？？？

考虑到所有这些，结果如下。希望它现在可以与您的文件夹正确扩展:)

Sub Invoice_Records()

    Dim ws As Worksheet
    Set ws = Worksheets("Admin2")

    Dim wbTemp As Workbook
    Dim wsTemp As Worksheet

    'Create an instance of the FileSystemObject
    Dim objFSO As Object
    Set objFSO = CreateObject("Scripting.FileSystemObject")

    'Get the folder object
    Dim objFolder As Object
    Set objFolder = objFSO.GetFolder("C:\Users\king_matthew\Documents\ELINV 2018")

    Dim objFile As Object

    Dim i As Long
    i = 2

    Dim FileExtension As String

    Dim filecountB As String
    filecountB = objFolder.Files.count

    Dim searchInvValue As Range
    Dim searchOrderNum As Range
    Dim searchDate As Range

    'Toggling screen updating prevents screen flicker and speeds up operations
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .StatusBar = True
    End With

    'This part clears all columns, otherwise if you were on line 10 last time you ran the code,
    'and then you deleted a commercial invoice it would only update up to line 9 but the legacy values of line 10 would still show
    ws.Columns("B:G").EntireColumn.Clear

    'Loops through each file in the directory
    For Each objFile In objFolder.Files

        'Update status bar to show progress
        Application.StatusBar = "Currently processing item " & (i - 1) & " out of " & filecountB

        'Paste file name
        ws.Cells(i, "B").Value2 = objFile.Name

        'Paste file path and add a hyperlink to it
        ws.Hyperlinks.Add Anchor:=ws.Cells(i, "C"), Address:=objFile.path, TextToDisplay:=objFile.path

        'Get the file extension
        FileExtension = UCase$(Right(objFile.Name, Len(objFile.Name) - InStrRev(objFile.Name, ".")))

        'Paste file extension
        ws.Cells(i, "D").Value2 = FileExtension

        'Only do operations on files with the extension "xlsm", otherwise skip
        If FileExtension = "xlsm" Then

            'This opens the current "objFile" document
            Set wbTemp = Workbooks.Open(Filename:=objFile.path)
            Set wsTemp = wbTemp.Sheets(1)

            'Find and paste "Date:"
            Set searchDate = wsTemp.Cells.Find("Date:")
            ws.Cells(i, "E").value = searchDate.Offset(, 1).value

            'Find and paste "Total Invoice Value"
            Set searchInvValue = wsTemp.Cells.Find("Total Invoice Value")
            ws.Cells(i, "F").Value2 = searchInvValue.Offset(, 1).Value2

            'Find "Order No:" and paste if not blank
            Set searchOrderNum = wsTemp.Cells.Find("Order No:")
            If Not searchOrderNum Is Nothing Then ws.Cells(i, "G").Value2 = searchOrderNum.Offset(, 1).Value2

            'Close the current "objFile" workbook
            wbTemp.Close
        End If

        'Go onto the next file
        i = i + 1
    Next objFile

    'Turn screen updating back on so that you can see the values being updated
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .StatusBar = False
    End With

    'Call FindingLastRow        'this does not currently seem necessary

End Sub