我在日常工作中一直在运行此代码，以保持订单和运输的最新状态，该代码在指定的位置打开电子表格，并返回以下内容，发票编号，公司名称，运输日期和总订单并将其放入一个主电子表格中。
我去年开始使用它，过去用了不到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
答案 0 :(得分：1)
好的，所以我更改了一些内容并删除了一些不必要的代码。这是我的“更改日志”：
FindingLastRow的呼叫，因为它目前无任何作用ActiveSheet wsTemp的行可能无法正常工作，请告知是否失败i的起始值更改为2 Range.Find("..")结果Application.ScreenUpdating调用
.Calculation和.EnableEvents中添加了切换功能，可以进一步加快编程速度
.ScreenUpdating类似，它们通过压制excel并仅专注于某些操作来加快速度.select
Activesheet，调用.select一样也会降低代码速度&而不是+ if语句清除重复代码
if中重复执行代码时，只需在它们之后 .cells(r,c)调用单元格时，您实际上可以只使用列字符串，因此为简单起见，我这样做了
.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