在Excel vba，Works中组合和清理数据，但寻找潜在的清理，5分钟的运行时间

Question

我目前正在开发一个项目，用于合并文件夹中多个工作簿的数据，提取我需要的信息（LC，部件号，估计发货日期），然后在数据透视表中显示该数据。

表格很好，但信息的提取需要很长时间，我希望有人能够帮我清理代码，甚至向我介绍我可能不知道的更快的功能。我已编码任何东西已经有一段时间了，所以如果我做得很差，我会道歉。

我会发布每个子文章，说明它正在做什么。

Populate_Data：此子程序调用所有其他Subs，并从文件夹位置的所有文件中提取第一个工作表。

Sub Populate_Data()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

'Call Delete Sheets to clean up any old data
Delete_Sheets

'Set the File Path to pull Files from
Dim FolderPath As String
Dim Filename As String
Dim Sheet As Worksheet
Dim intCurrentColumn As Integer

intCurrentColumn = 1

FolderPath = "P:\RNL\Expedite Reports - Incoming\"
Filename = Dir(FolderPath + "*.xls*")

'Loop through and copy the first sheet from each workbook
Do While Filename <> ""
    Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
        Sheets(1).Copy After:=ThisWorkbook.Sheets(2)
    Workbooks(Filename).Close
    Filename = Dir()
Loop

'Create Loop for gathering and copying Data
Dim intSheetCount, intCurrentCount As Integer
intSheetCount = ThisWorkbook.Sheets.Count

For intCurrentCount = 3 To intSheetCount

    Sheets(intCurrentCount).Activate
    Collect_Data (intCurrentColumn)
    Append_Data (intCurrentColumn)
    intCurrentColumn = intCurrentColumn + 3

Next intCurrentCount

'Call Clean Parts to clean up the Parts worksheet
Clean_Parts

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Delete_Sheets：这会删除所有多余的工作表，并清理它仍然存在的任何数据的零件工作表。

Sub Delete_Sheets()

'Deletes all sheets except specified sheets using codenames
Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
    Select Case ws.CodeName
    Case "Master", "Parts"
            Case Else
        ws.Delete
    End Select
Next

'Clean up Parts Sheet
ThisWorkbook.Sheets(2).Rows("2:" & Rows.Count).ClearContents

End Sub

收集数据：这是我猜的可以使用最清理/更好的方法吗？这将从每个工作表中提取相关数据，并将其放在“零件”工作表上的3列组中。我给出的数据不够一致，无法使用偏移或任何东西来确定数据在工作表上的位置，因此可以通过标题进行搜索。

Sub Collect_Data(intCurrentColumn As Integer)

Dim PartsWs As Worksheet
Set PartsWs = ThisWorkbook.Sheets(2)

Dim CellRange As Range
Dim NextRow As Integer

Dim ThisSheet As Worksheet
Set ThisSheet = ThisWorkbook.ActiveSheet

'Look to Simplify This
'Search the Current Active Sheet
With ThisSheet

    'LC
    Set CellRange = .Rows(1).Find(What:="LC", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
    If Not CellRange Is Nothing Then
        CellRange.EntireColumn.Copy Destination:=PartsWs.Columns(intCurrentColumn)
    End If

    'Part Num
    Set CellRange = .Rows(1).Find(What:="Part Num", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
    If Not CellRange Is Nothing Then
        CellRange.EntireColumn.Copy Destination:=PartsWs.Columns(intCurrentColumn + 1)
    End If

    'Estimated Ship Date
    Set CellRange = .Rows(1).Find(What:="Estimated Ship Date*", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
    If Not CellRange Is Nothing Then
        CellRange.EntireColumn.Copy 
Destination:=PartsWs.Columns(intCurrentColumn + 2)
    End If
End With
'This Section End

End Sub

附加数据：这用于将零件表上的列中的数据附加到前三列，基本上只是将数据作为列表。

Sub Append_Data(intCurrentColumn)

Dim PartsWs As Worksheet
Set PartsWs = ThisWorkbook.Sheets(2)

Dim CopyRange As Range
Dim lngLastRow, lngLastPartsA As Long

'Get the last rows in column A and the column we are starting the range from
lngLastPartsA = PartsWs.Cells(Rows.Count, 1).End(xlUp).Row
lngLastRow = PartsWs.Cells(Rows.Count, intCurrentColumn).End(xlUp).Row

'Set range to copy
With PartsWs
    Set CopyRange = .Range(.Cells(2, intCurrentColumn), .Cells(lngLastRow, intCurrentColumn + 2))
End With

'Copy range after data already in Column A
CopyRange.Copy (PartsWs.Cells(lngLastPartsA + 1, 1))

End Sub

最后，清洁部件：这只是清理“估计发货日期”列中没有信息的任何行的部件工作表，以及在移动所有数据后清理所有其余列。

Sub Clean_Parts()

Dim PartsWs As Worksheet
Set PartsWs = ThisWorkbook.Sheets(2)

Dim intCount As Integer
Dim lngColumnCount, lngLastRow As Long

lngColumnCount = PartsWs.Cells(1, Columns.Count).End(xlToLeft).Column

For intCount = 4 To lngColumnCount

    PartsWs.Columns(4).EntireColumn.Delete

Next intCount

lngLastRow = PartsWs.Cells(Rows.Count, 1).End(xlUp).Row

For intCount = 2 To lngLastRow

    If IsEmpty(PartsWs.Cells(intCount, 3)) Then

        PartsWs.Rows(intCount).EntireRow.Delete
        intCount = intCount - 1

    End If

Next intCount

End Sub

如果其中任何一个太模糊，或者我需要重新发布一个更小/更直接的问题，那么请告诉我。我感谢任何帮助！

编辑：经过进一步测试，信息的提取和解析只需要大约2分钟（仍然很长时间），这意味着我的清理工作将在剩余的时间内完成。我目前正在寻找其他加速清理的方法，但我仍然对这些想法持开放态度。

Answer 1

如果所有文件都在网络驱动器上，那可能会让它陷入困境......也许您可以先将它们复制到C：驱动器中？

Answer 2

任何进程都会在您的C驱动器上运行得更快，而不是企业网络驱动器。此外，要进行所有聚合，请从下面的链接下载并安装AddIn。

https://www.rondebruin.nl/win/addins/rdbmerge.htm