Question

我编写了以下代码，从特定目录中的每个工作簿复制一个特定的Range并将其粘贴到活动工作表中，它可以按预期工作。

我无法弄清楚的是如何遍历整个文件夹结构，而不仅仅是顶层。

Option Explicit

Sub LoopThroughDirectory()

Dim myFile As String, filepath As String
Dim wbc As Long, ws As Worksheet, wb As Workbook
Dim diaFolder As FileDialog

Set diaFolder = Application.FileDialog(msoFileDialogFolderPicker)
diaFolder.AllowMultiSelect = False

If diaFolder.Show = -1 Then
myFile = diaFolder.SelectedItems(1)
End If

wbc = 0
filepath = myFile

Application.ScreenUpdating = False

'Only try to open xlsm workbooks
myFile = Dir(filepath & "\*.xlsm")

 'Opens workbooks 
 Do While Len(myFile) > 0
    'Make sure myFile isn't ThisWorkbook
    If Split(myFile & ".", ".")(0) <> Split(ThisWorkbook.Name & ".", ".")(0) Then

        Set wb = Workbooks.Open(Filename:=filepath & "/" & myFile, ReadOnly:=True)
    
        'Check if there is a Results worksheet
        On Error Resume Next
        Set ws = wb.Worksheets("Results")
        On Error GoTo 0
        If Not ws Is Nothing Then
             'Transfer cells B2 & C2 from the results worksheet
             With ws.Range("A4:L4")
                 ThisWorkbook.ActiveSheet.Range("B4").Offset(wbc, 0).Resize(.Rows.Count,     .Columns.Count) = .Value
             End With
        End If

        'Close wb most recently opened
        wb.Close SaveChanges:=False

        wbc = wbc + 1
        If wbc > 1000 Then Exit Do

    End If

    Set ws = Nothing
    myFile = Dir
Loop

ActiveWorkbook.Save

End Sub

遍历文件夹中的文件夹

0 个答案: