目录之间的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