目錄之間的Excel VBA宏文件副本

Question

我需要一些幫助，以便使此代碼更快地運行。目前它像糖蜜一樣運行，太慢而不實用。

此程序旨在將文件目錄中的每個文件與文件名列表進行比較。這些文件根據生成日期在子目錄中列出，因此典型的文件路徑可能類似於> 16> 06> 27> example.wav。我需要複製到另一個目錄中的文件名列表位於Sheet1列R中。

我在Excel 2010中啓動了此項目，並升級到了Excel 2016的64位版本，以充分利用擴展的虛擬內存上限在該版本的Office，但它仍然運行非常緩慢，並在程序運行完成之前崩潰。

存儲文件的文件夾和我將其複製到的文件夾位於網絡驅動器上，存儲在辦公室的服務器中。這是造成這個問題嗎？我的代碼有問題嗎？我無法想象一臺電腦的引擎蓋下，我遇到了一對嵌套For循環和二進制搜索的問題。

Sub CopyFile() 
Application.Calculation = xlCalculationManual 'trying to speed things up. 
ActiveSheet.DisplayPageBreaks = False 

'This code takes the directory where the files are stored from the Active worksheet Range B3 and the goal directory where the copies are to be stored from Range G3 
'It then lists all of the subdirectories (months) of the year we start with in column B, 
'all of the days of that month in Column C and all the files in a given day in column D. 

'List all the months in Column B 
ListFilesinFolder ("B") 'lists the months in the year directory 

With ActiveSheet 
For i = 6 To Range("B6", Range("B6").End(xlDown)).Rows.Count + 5 
    Range("B3") = Range("B3") & Range("B" & i) & "\" 'Add the month to the folder name 
    ListFilesinFolder ("C") 'List all of the days in the month in Column C 

    For x = 6 To Range("C6", Range("C6").End(xlDown)).Rows.Count + 5 

     Range("B3") = Range("B3") & Range("C" & x) & "\" 'Add the day to the folder name 
     ListFilesinFolder ("D") 'List all of the files in column D 

     For y = Range("D6", Range("D6").End(xlDown)).Rows.Count + 5 To 6 Step -1 

      binarySearch (y) 'Search for the filename against our list of potential filenames in Sheet1 column R 

     Next y 

     Range("D6", Range("D6").End(xlDown)).ClearContents 
     Range("B3") = Left(Range("B3"), 23) 'Get the folder name in B3 back to year and month 

    Next x 

    Range("C6", Range("C6").End(xlDown)).ClearContents 
    Range("B3") = Left(Range("B3"), 20) 'Get the folder name in B3 back to just the year 
Next i 
End With 

Application.Calculation = xlCalculationAutomatic 

End Sub 

Sub ListFilesinFolder(ColName As String) 'lists all the files or sub-directories in a folder in the column passed to this function. 
    Dim Value As String 
    Dim strt As Range 
    Set strt = Range(ColName & "6") 
    Value = Dir(Range("B3"), &H1F) 
    Do Until Value = "" 
    If Value <> "." And Value <> ".." Then 
     strt = Value 
     Set strt = strt.Offset(1, 0) 
    End If 
    Value = Dir 
    Loop 
End Sub 

Sub binarySearch(index As Long) 
Dim low As Double 
Dim mid As Long 
Dim high As Double 
Dim sheetNotesInfo As Worksheet 
Dim src As String, dst As String, fl As String 

'Source directory 
src = Range("B3") 
'Destination directory 
dst = Range("G3") 
'File name 
fl = Range("B6") 

'sheet with potential file names 
Set sheetNotesInfo = ActiveWorkbook.Sheets("Sheet1") 

low = 2 
high = sheetNotesInfo.UsedRange.Rows.Count 

      Do While (low <= high) 

       mid = (low + high)/2 

       If (sheetNotesInfo.Range("R" & mid) > Left(Range("D" & index), 19)) Then 
        high = mid - 1 

       ElseIf (sheetNotesInfo.Range("R" & mid) < Left(Range("D" & index), 19)) Then 
        low = mid + 1 

       Else 'found 
       src = Range("B3") 'setting the source of the file to be the source folder 
       fl = Range("D" & index) 'setting the filename to be the filename we are currently inspecting 

       On Error Resume Next 
        FileCopy src & "\" & fl, dst & "\" & fl 
        If Err.Number <> 0 Then 
        End If 
       On Error GoTo 0 
       low = 1 
       high = -1 
       End If 
      Loop 

End Sub 

Answer 1

我想我想通了。我至少有它的工作。

如果該列中沒有內容，則問題循環到Range("ExampleRange", Range("ExampleRange").End(xlDown)).Rows.Count。在列中沒有內容的情況下，我for循環的索引被設置爲...例如，「1048576」，然後循環到6並在每個空白單元格之間運行二分搜索。

所以是的。浪費時間運行循環和計算是完全無用的Loooots。我的部分調試不當。

我用一個簡單的If語句修復它，檢查列中的第一個單元格是否有任何內容，如果沒有，退出For循環。

If Not Range("ExampleRange") = "" Then 

    binarySearch (y) 'Search for the filename against our list of potential filenames in Sheet1 column R 

Else 

    Exit For 

End If