VBA模板导入运行缓慢，我想
第一次海报，但已经search的网站，并使用您的问题的反馈，把下面的代码放在一起。 它完美的工作，但似乎是非常缓慢。 花费80多分钟导入1500个模板现在可能我期待很多，但是如果有人可以检查我看到我做了什么错误
Sub ProcessFiles() Dim strPath As String Dim strFile As String Dim wbkSrc As Workbook Dim wshSrc As Worksheet Dim wshTrg As Worksheet Dim lngRow As Long With Application.FileDialog(4) ' msoFileDialogFolderPicker If .Show Then strPath = .SelectedItems(1) Else MsgBox "You didnt Select the import folder Dummy :)", vbExclamation Exit Sub End If End With Application.Calculation = xlCalculationManual Application.ScreenUpdating = False Application.DisplayStatusBar = False Application.EnableEvents = False If Right(strPath, 1) <> "\" Then strPath = strPath & "\" End If Set wshTrg = ActiveSheet lngRow = 2 strFile = Dir(strPath & "*.xls*") Do While strFile <> "" Set wbkSrc = Workbooks.Open(strPath & strFile) Set wshSrc = wbkSrc.Worksheets(1) wshSrc.Range("E1").Copy wshTrg.Range("F" & lngRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=True wshSrc.Range("F1").Copy wshTrg.Range("G" & lngRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=True wshSrc.Range("C1:C16").Copy wshTrg.Range("H" & lngRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=True wshSrc.Range("F8:F16").Copy wshTrg.Range("X" & lngRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=True wshSrc.Range("G8:G16").Copy wshTrg.Range("AG" & lngRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=True wshSrc.Range("H8:H16").Copy wshTrg.Range("AP" & lngRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=True lngRow = lngRow + 1 wbkSrc.Close SaveChanges:=False strFile = Dir Loop Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Application.DisplayStatusBar = True Application.EnableEvents = True End Sub 请试试这个代码：
Sub ProcessFiles() Dim strPath As String Dim strFile As String Dim wbkSrc As Workbook Dim wshSrc As Worksheet Dim wshTrg As Worksheet Dim lngRow As Long With Application.FileDialog(4) ' msoFileDialogFolderPicker If .Show Then strPath = .SelectedItems(1) Else MsgBox "You didnt Select the import folder Dummy :)", vbExclamation Exit Sub End If End With Application.Calculation = xlCalculationManual Application.ScreenUpdating = False Application.DisplayStatusBar = False Application.EnableEvents = False If Right(strPath, 1) <> "\" Then strPath = strPath & "\" End If Set wshTrg = ActiveSheet lngRow = 2 strFile = Dir(strPath & "*.xls*") Do While strFile <> "" Set wbkSrc = Workbooks.Open(strPath & strFile) Set wshSrc = wbkSrc.Worksheets(1) wshTrg.Range("F" & lngRow).Value = wshSrc.Range("E1").Value wshTrg.Range("G" & lngRow).Value = wshSrc.Range("F1").Value wshTrg.Range("H" & lngRow).Value = wshSrc.Range("C1:C16").Value wshTrg.Range("X" & lngRow & ":X" & lngRow + 8).Value = wshSrc.Range("F8:F16").Value wshTrg.Range("AG" & lngRow & ":AG" & lngRow + 8).Value = wshSrc.Range("G8:G16").Value wshTrg.Range("AP" & lngRow & ":AP" & lngRow + 8).Value = wshSrc.Range("H8:H16").Value lngRow = lngRow + 1 wbkSrc.Close SaveChanges:=False strFile = Dir Loop Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Application.DisplayStatusBar = True Application.EnableEvents = True End Sub
希望这个帮助。
下面的代码在2分55秒内处理1511个文件（每个28Kb）
从closures的文件获取数据，然后将公式转换为值
Option Explicit Public Sub ProcessFiles() Dim srcPath As String, srcFile As String, srcWs As String Dim r As Long, c As Long, ws As Worksheet, fullName As String, t As Double srcPath = GetPath: If Len(srcPath) = 0 Then Exit Sub t = Timer xlSpeed True srcFile = Dir(srcPath & "*.xls*") Set ws = ActiveSheet srcWs = "Sheet1" r = 2 With ws Do While Len(srcFile) > 0 fullName = "= '" & srcPath & "[" & srcFile & "]" & srcWs & "'!" .Cells(r, 5) = fullName & "E1" 'F = 6 .Cells(r, 6) = fullName & "F1" 'G = 7 For c = 1 To 16 .Cells(r, c + 7) = fullName & .Cells(c, 3).Address 'C1:C16 to H+ = 8 Next For c = 8 To 16 .Cells(r, c + 16) = fullName & .Cells(c, 6).Address 'F8:F16 to X+ = 24 .Cells(r, c + 25) = fullName & .Cells(c, 7).Address 'G8:G16 to AG+ = 33 .Cells(r, c + 34) = fullName & .Cells(c, 8).Address 'H8:H16 to AP+ = 42 Next r = r + 1: srcFile = Dir Loop .UsedRange.Value2 = .UsedRange.Value2 End With xlSpeed False Debug.Print "Time: " & Format(Timer - t, "0.000") & " sec" 'Time: 175.086 sec End Sub
Public Function GetPath() As String With Application.FileDialog(4) 'msoFileDialogFolderPicker If .Show Then GetPath = .SelectedItems(1) If Right(GetPath, 1) <> "\" Then GetPath = GetPath & "\" Else MsgBox "Please select the import folder", vbInformation End If End With End Function Public Sub xlSpeed(Optional ByVal flag As Boolean = False) With Application .Calculation = IIf(flag, xlCalculationManual, xlCalculationAutomatic) .ScreenUpdating = Not flag .DisplayStatusBar = Not flag .EnableEvents = Not flag End With End Sub
SpeadSheetGuru定时器我的代码花了7分11秒处理1500个8K excel文件。
注意：从技术上讲，这个问题应该移到CodeReview
Sub ProcessFiles() Dim LastRow As Long Dim strFile As String, strPath As String Dim results As Variant strPath = getFileDialogDirPath If Len(strPath) = 0 Then Exit Sub EnableEvents False strFile = Dir(strPath & "*.xls*") Do While strFile <> "" results = getFileInfoArray(strPath & strFile) With ThisWorkbook.ActiveSheet 'Ron de Bruin: Find last row, column or last cell --> https://www.rondebruin.nl/win/s9/win005.htm LastRow = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row .Cells(LastRow + 1, "E").Resize(1, UBound(results, 2)).Value = results End With strFile = Dir Loop EnableEvents True End Sub Private Function getFileInfoArray(FileName As String) As Variant With Workbooks.Open(FileName) With .Worksheets(1) getFileInfoArray = getSourceValues(.Range("E1,F1,C1:C16,F8:F16,G8:G16,H8:H16")) End With .Close SaveChanges:=False End With End Function Private Sub EnableEvents(TurnOn As Boolean) With Application .Calculation = IIf(TurnOn, xlCalculationAutomatic, xlCalculationManual) .ScreenUpdating = TurnOn .DisplayStatusBar = TurnOn .EnableEvents = TurnOn .DisplayAlerts = TurnOn End With End Sub Private Function getSourceValues(Source As Range) Dim results As Variant Dim cell As Range Dim x As Long ReDim results(1 To 1, 1 To Source.Cells.Count) For Each cell In Source.Cells x = x + 1 results(1, x) = cell.Value Next getSourceValues = results End Function Private Function getFileDialogDirPath() As String Dim strPath As String With Application.FileDialog(4) ' msoFileDialogFolderPicker If .Show Then strPath = .SelectedItems(1) Else MsgBox "You didnt Select the import folder Dummy :)", vbExclamation Exit Function End If End With If Right(strPath, 1) <> "\" Then strPath = strPath & "\" getFileDialogDirPath = strPath End Function
我修改了我的原始答案以使用Ron de Bruin： 查找最后一行，最后一列或最后一个单元格，因为E列中的最后一个单元格有时是空白的。 我还将从文件中检索信息的代码移动到Function getFileInfoArray(FileName As String) ，以使debugging变得更容易。