VBA: Unterordner durchsuchen

Sub test()



    Dim strPath As String

    Dim strType As String

    Dim strFile As String

    Dim strKeyWord As String

    Dim i As Long

    

    Application.ScreenUpdating = False



    strPath = "C:\Users\.........................."

    strType = "*.xlsm"



    If strPath = "" Then

        Exit Sub

    Else

        strFile = Dir(strPath & strType)

        Do While Len(strFile) > 0

        Workbooks.Open Filename:=strPath & strFile



        strKeyWord = "Japan"



        For i = 1 To Worksheets.Count

            If Worksheets(i).Name = strKeyWord Then

                If Cells(1, 1).Value > "" Then

                    Workbooks("Testdatei").Worksheets("Tabelle1").Cells(2, 1).Value = strFile

                    Exit For

                End If

            End If

        Next

        Workbooks(strFile).Close

        strFile = Dir()

        Loop

    End If

End Sub