打开所有文件夹路径中的所有文件，然后跳到空文件夹

Question

我需要在每个文件夹中打开文件复制并粘贴，但代码停止下一个循环。

我参考的代码https://exceloffthegrid.com/vba-code-loop-files-folder-sub-folders/

这里的代码已经试过了（代码在下一个 i 停止）

Option Explicit

Sub LoopAllFilesInFolder()

Dim folderName As String
Dim FSOLibrary As Object
Dim FSOFolder As Object
Dim FSOFile As Object

Dim i As Long, LastRow As Long
Dim Ws As Worksheet
Dim Ws2 As Worksheet

'DATA
Dim A As Variant
Dim B As Worksheet
Dim C As Workbook

Set Ws = ThisWorkbook.Worksheets("Path_Import")
Set Ws2 = ThisWorkbook.Worksheets("DATA_ORDER")

LastRow = Ws.Range("G11").End(xlDown).Row

Ws.Activate

For i = 11 To LastRow

    'Set the file name to a variable
    folderName = Range("G" & i).Value
    
    If folderName <> VBA.Constants.vbNullString Then
    
        'Set all the references to the FSO Library
        Set FSOLibrary = CreateObject("Scripting.FileSystemObject")
        Set FSOFolder = FSOLibrary.GetFolder(folderName)
        Set FSOFile = FSOFolder.Files

        'Use For Each loop to loop through each file in the folder
        For Each FSOFile In FSOFile

            Set A = Application.Workbooks.Open(FSOFile)
    
            Set B = A.Sheets(1)
            
            B.Cells(Rows.Count, 1).End(xlUp).Offset(0, 28).Select
            Range(Selection, Cells(1, 1)).Copy
        
            If Ws2.Range("A1") = "" Then
    
                Ws2.Cells(Rows.Count, 1).End(xlUp).PasteSpecial 'xlPasteValues
    
            Else
                Ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial 'xlPasteValues
        
            End If
        
            A.Close SaveChanges:=False

        Next
            
        'Release the memory
        Set FSOLibrary = Nothing
        Set FSOFolder = Nothing
        Set FSOFile = Nothing

    End If

Next i

End Sub

Answer 1

您需要更改循环 for 语句

For Each FSOFile In FSOFile

至

For Each FSOFile In FSOFolder.Files

并删除行Set FSOFile = FSOFolder.Files