目录之间的Excel VBA宏文件复制

Question

I need some help trying to make this code run more quickly. Presently it runs like molasses, far too slow to be practical.

This program is intended to compare each file in a directory of files against a list of file names. The files are listed in sub-directories according to the date they were generated, so a typical file path might look like >16>06>27>example.wav. The list of file names I need to copy into another directory is located in Sheet1, column R.

I started this project in Excel 2010 and upgraded to the 64 bit version of Excel 2016 in order to take advantage of the expanded virtual memory cap in that version of Office but it's still running VERY slowly and crashing before the program runs to completion.

Both the folder where the files are stored and the folder I'm copying them to are on a network drive, stored in the office's server. Is that causing the issue? Am I doing something wrong with the code? I can't imagine a computer with the power under the hood that mine has is encountering problems with a couple nested For loops and a binary search.

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

I think I figured it out. I at least got it working.

The issue was looping to Range("ExampleRange", Range("ExampleRange").End(xlDown)).Rows.Count in cases where there were no contents in that column. In cases where there were no contents in the column the index of my for loop was getting set to... for example, "1048576" and then looping down to 6 and running a binary search on every blank cell between.

So yeah. Loooots of wasted time running loops and calculations that were completely useless. Improper debugging on my part.

I fixed it with a simple If statement checking if the first cell in the column had anything in it and, if not, exiting that For loop.

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