Циклический просмотр всех файлов Excel в папке для извлечения данных - отображение ошибки: файл отсутствует

Question

У меня есть набор из ~ 550 файлов Excel, которые мне нужны для извлечения данных из мастер-листа. Файлы находятся в одном главном каталоге, сгруппированы в 17 подпапок. Все файлы имеют одинаковый формат, например, LT-A01-001. Я настроил макрос на l oop через 17 подпапок и все файлы Excel в этих подпапках и скопировал несколько наборов значений на мастер-лист.

В тот момент, когда я запускаю макрос, он возвращается с «Ошибка 1004: мы не смогли найти LT-A01-001.xlsx». Есть идеи, что я пропустил?

'Sub ExtractLTdata()

    Dim designfile As String, x As Integer, wbmstr As Workbook, wbiso As Workbook, mstrsheet As Worksheet, starttime As Double, secondsrun As Double

    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    starttime = Timer

    'create new sheet for each extract with current date & time using template sheet
    Sheets("TEMPLATE_data").Select
    Sheets("TEMPLATE_data").Copy After:=Sheets(2)
    ActiveSheet.Name = WorksheetFunction.Text(Now(), "d-mmm-yyyy hmm am/pm")
    Set wbmstr = ThisWorkbook
    Set mstrsheet = ActiveSheet

    'loop for area folders
    For x = 1 To 17

        'loop through all .xlsx in folder
        designfile = Dir("C:\Users\cadialg\Documents\CB\LT\Area " & x & "\*.xlsx")

        Do While designfile <> ""

            Set wbiso = Workbooks.Open(filename:=designfile)

            DoEvents

                'copy & paste design load data
                wbiso.Worksheets("0.SUMMARY").Range("D21:D27").Copy

                wbmstr.mstrsheet.Range("A1").End(xlDown).Offset(1, 0).PasteSpecial Transpose:=True

                'copy & paste foundation geometry data
                wbiso.Worksheets("0.SUMMARY").Range("D32:D44").Copy

                wbmstr.mstrsheet.Range("A1").End(xlDown).Offset(0, 7).PasteSpecial Transpose:=True

                'copy & paste no. of bars req
                wbiso.Worksheets("2.THICKENING").Range("E43:E44").Copy

                wbmstr.mstrsheet.Range("A1").End(xlDown).Offset(0, 20).PasteSpecial Transpose:=True

            wbiso.Close SaveChanges:=False

            DoEvents

            'next file
            filename = Dir
        Loop
    Next

    secondsrun = Round(Timer - starttime, 2)

    MsgBox "This code ran successfully in " & secondsrun & " seconds", vbInformation

    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub

Answer 1

Это еще один способ l oop папок в каталоге:

Sub Loop_Files()

    Dim Path As String: Path = "XXXX:\XXXX\XXXX\XXXX\New folder" & "\"
    Dim Files_Type As String: Files_Type = "*.xlsx*"
    Dim StrFile As String
    Dim wbiso As Workbook

    StrFile = Dir(Path & Files_Type)

    If StrFile <> "" Then

        Do While Len(StrFile) > 0

            Set wbiso = Workbooks.Open(Filename:=Path & StrFile)
            wbiso.Close SaveChanges:=False

            StrFile = Dir

        Loop

    Else

        MsgBox "No files found."

    End If

End Sub