Question

我需要一些帮助才能让这段代码更快地运行。现在它像糖蜜一样运行，实在太慢了。

此程序旨在将文件目录中的每个文件与文件名列表进行比较。这些文件根据它们生成的日期列在子目录中，因此典型的文件路径可能看起来像＆gt; 16＆gt; 06＆gt; 27＆gt; example.wav。我需要复制到另一个目录的文件名列表位于Sheet1的R列。

我在Excel 2010中启动了这个项目，并升级到64位版本的Excel 2016，以便利用该版本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并在每个空白单元格之间运行二进制搜索。

所以是的。浪费时间的循环运行循环和完全无用的计算。我的调试不当。

我用一个简单的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

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

1 个答案: