0

我非常感谢您花时间阅读我的消息，并且我了解堆栈溢出的目的更多是针对失败的代码，但是我是新手，想获得一些提示 VBA 问题：在使用文件搜索对象（相对于使用目录功能）时，我看到过类似的问题询问有关长时间运行的问题。就我而言，我的运行时间超过 3 小时，因为我试图遍历每个子文件夹中的 1000 个子文件夹和 100 个文件。我不确定如何将在线阅读的答案应用于我正在使用的特定代码，因为我必须遍历文件夹的不同子文件夹。问题已编辑：我想降低宏的运行时间。我认为这里的问题是 FSO 正在遍历许多不符合条件（文件名和日期）的子文件夹和文件。如何减少运行时间以避免宏遍历所有这些文件夹和文件？代码用途：从 2019 年 1 月 1 日至 1 月 1 日期间的所有子文件夹中的所有“结果”文件中复制/粘贴两列，2020 到活动工作簿。非常感谢你的帮助，

请看下面我的代码：

Sub LoopAllSubFolders(FSOFolder As Object)
Dim R0 As Range, R1 As Range, R2 As Range, R3 As Range, R4 As Range, RN0 As Range, RN1 As Range, R5 As Range, RN2 As Range, RN3 As Range
Dim FSOSubFolder As Object
Dim FSOFile As Object
Dim FSOFilepath As String
Dim wb As Workbook
Dim sspec As String
Dim DateY As Date
Dim DateW As Date

'For each subfolder, macro is called'
For Each FSOSubFolder In FSOFolder.SubFolders
DateY = DateSerial(2019, 1, 1)
DateW = DateSerial(2020, 1, 1)
If FSOSubFolder.DateLastModified > DateY Then
If FSOSubFolder.DateLastModified < DateW Then

    LoopAllSubFolders FSOSubFolder

    End If
    End If
Next


For Each FSOFile In FSOFolder.Files
sspec = "Results"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
FSOFilepath = FSOFile.Path
If Right(FSOFilepath, 3) = "csv" Then
If InStr(FSOFilepath, sspec) > 0 Then
If FSOFile.DateLastModified > DateY Then
If FSOSFile.DateLastModified < DateW Then

Set wb = Workbooks.Open(FSOFile.Path)
Set R0 = wb.Sheets(1).Cells(2, 1)
Set R1 = R0.End(xlDown)
Set R2 = Range(R0, R1)
Set R3 = wb.Sheets(1).Cells(2, 2)
Set R4 = R3.End(xlDown)
Set R5 = Range(R3, R4)


Set RN0 = ThisWorkbook.Sheets(1).Cells(1, 1)
Set RN1 = RN0.End(xlDown)
Set RN2 = ThisWorkbook.Sheets(1).Cells(1, 2)
Set RN3 = RN2.End(xlDown)



wb.Sheets(1).Activate
R2.Select
Selection.Copy
ThisWorkbook.Activate
RN0.Select
RN1.Offset(1, 0).Select
ActiveSheet.Paste

wb.Sheets(1).Activate
R5.Select
Selection.Copy
ThisWorkbook.Activate
RN3.Offset(1, 0).Select
ActiveSheet.Paste

wb.Close
Application.CutCopyMode = False
End If
End If
End If
End If
Next FSOFile
ThisWorkbook.Activate
ThisWorkbook.Save

End Sub

Sub loopAllSubFolderSelectStartDirectory()

Dim FSOLibrary As Object
Dim FSOFolder As Object
Dim folderName As String
Dim fileName As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False
ThisWorkbook.Activate

Range("A1").Value = "ID"
Range("A2").Value = "ID"
Range("B1").Value = "Value"
Range("B2").Value = "Value"


'Set the folder name to a variable
folderName = "\\pah1\path2\"

'Set the reference to the FSO Library
Set FSOLibrary = CreateObject("Scripting.FileSystemObject")


'Another Macro call LoopAllSubFolders Macro to start
LoopAllSubFolders FSOLibrary.GetFolder(folderName)


Application.ScreenUpdating = True

ThisWorkbook.Activate
Rows(2).EntireRow.Delete


End Sub
4

2 回答 2

0

这是使用数组的解决方案。

Option Explicit

Const StartDate As Date = #1/1/2019#            ' inclusive
Const EndDate As Date = #12/31/2019#            ' inclusive

Private Sub Test()

    Dim Arr() As String
    Dim i As Long

    Arr = ListOfFiles
    For i = 1 To UBound(Arr)
        Debug.Print i, Arr(i)
    Next i

    With ActiveSheet
        .Cells(1, "B").Resize(UBound(Arr)).Value = Application.Transpose(Arr)
    End With
End Sub

Function ListOfFiles() As String()
    ' code by:
    ' https://stackoverflow.com/questions/14245712/cycle-through-sub-folders-and-files-in-a-user-specified-root-directory
    ' modified for this project:
    ' https://stackoverflow.com/questions/60536325/lower-run-time-currently-3-hours-vba-loop-through-specific-subfolders?noredirect=1#comment107097419_60536325
    ' by Variatus @STO 05 Mar 2020

    ' set the start directory as required
    Const StartDir As String = "F:\AWK PC\Drive E (Archive)\PVT Archive\"

    Dim Fun() As String                     ' function return array
    Dim ArrIdx As Long
    Dim RootDir As String
    Dim Fso As FileSystemObject
    Dim FirstFld As Folder
    Dim Fld As Folder
    Dim Fltr As String

    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = StartDir
        .AllowMultiSelect = False
        If Not .Show Then
            MsgBox "No folder selected!" & vbCr & _
                   "Exiting script.", vbInformation, "Cancel action"
            Exit Function
        End If
        RootDir = .SelectedItems(1)
    End With

    ReDim Fun(1 To 10000)   ' allow a number of files larger than expected
                            ' it's important to start at 1
    ArrIdx = 0
    Set Fso = New FileSystemObject
    Set FirstFld = Fso.GetFolder(RootDir)
    Fltr = ".cvs"
    ListFiles FirstFld, Fltr, Fun, ArrIdx

    For Each Fld In FirstFld.SubFolders
        ListFiles Fld, Fltr, Fun, ArrIdx
        ListFolders Fld, Fltr, Fun, ArrIdx
    Next Fld

    ReDim Preserve Fun(1 To ArrIdx)
    ListOfFiles = Fun
    Application.StatusBar = "Done"
End Function


Sub ListFolders(FirstFld As Folder, _
                Fltr As String, _
                Fun() As String, _
                Idx As Long)

    Dim Fld As Folder

    For Each Fld In FirstFld.SubFolders
        ListFiles Fld, Fltr, Fun, Idx
        ListFolders Fld, Fltr, Fun, Idx
    Next Fld
End Sub

Sub ListFiles(Fld As Folder, _
              Fltr As String, _
              Fun() As String, _
              Idx As Long)

    Dim ModDate As Date
    Dim Fil As File

    For Each Fil In Fld.Files
        ' exclude temporary files marked with ~ by the system
        With Fil
            If (Right(.Name, 4) = Fltr) And (Asc(.Name) <> 126) Then
                ModDate = Fil.DateLastModified
                ' skip files not within date range
                If (ModDate >= StartDate) And (ModDate <= EndDate) Then
                    Idx = Idx + 1
                    Fun(Idx) = Fld.Path & "\" & .Name
                    If Idx Mod 50 = 1 Then Application.StatusBar = Idx & " files copied."
                End If
            End If
        End With
    Next Fil
End Sub

有 3 个常量需要设置，StartDate在EndDate代码表的顶部和StartDir过程中ListOfFiles。如果您不设置后者，Folderpicker 将在您上次使用的目录中启动。ActiveSheet我还建议将Sub中的引用更改Test为指向您在工作簿中插入以进行测试的空白表。

一切就绪后，运行Test程序。它将调用ListOfFiles遍历所有指定文件夹和子文件夹并返回限定文件名数组的函数。该列表Test首先打印到立即窗口，然后打印到上述空白工作表的 B 列。这将使您了解您拥有什么以及可以用它做什么。您的测试应包括检查第一个和最后一个合格文件是否包含在数组和列表中。切断它们是一个非常流行的编程错误，我的测试仅限于不崩溃的代码。

我测试了大约 300 个文件，提取了其中的 71 个，大约需要 3 秒。按照这个标准，你的清单应该会在 2 分钟内准备好。状态栏中有一个进度指示器。

我不明白您想对这些文件做什么，但如果您打算从中提取数据，请注意，您不必为此目的打开它们。我觉得从封闭的 CSV 文件中提取数据的最佳方法不在您当前问题的范围内。

于 2020-03-05T04:44:55.423 回答
0

使用 Dir() 的非递归方法：

Sub Tester()
    Dim f
    For Each f In GetFiles("C:\My\Stuff\Analysis\")
        Debug.Print f
        'extract your data
    Next f
End Sub

Function GetFiles(startPath As String) As Collection 'of file paths
    Dim fso As Object, rv As New Collection, colFolders As New Collection
    Dim fPath As String, subFolder As Object, f, dMin, dMax, dtMod

    Set fso = CreateObject("Scripting.FileSystemObject")

    dMin = DateSerial(2019, 1, 1)
    dMax = DateSerial(2020, 1, 1)

    colFolders.Add startPath

    Do While colFolders.Count > 0
        fPath = colFolders(1)
        colFolders.Remove 1
        'process subfolders
        For Each subFolder In fso.getfolder(fPath).subfolders
            dtMod = subFolder.DateLastModified
            If dtMod > dMin And dtMod < dMax Then
                colFolders.Add subFolder.Path
            End If
        Next subFolder
        'process files
        f = Dir(fso.buildpath(fPath, "*Results*.csv"), vbNormal)
        Do While f <> ""
            f = fso.buildpath(fPath, f)
            dtMod = FileDateTime(f)
            If dtMod > dMin And dtMod < dMax Then
                rv.Add f
            End If
            f = Dir()
        Loop
    Loop
    Set GetFiles = rv
End Function

看起来您正在使用网络文件共享，因此性能不佳的部分原因可能是使用非本地驱动器。

于 2020-03-05T06:23:06.450 回答