Excel Macro search and copy function in subfolders

Hello everybody,
i've again some problems with my VBA-Code and hopefully some of you can help me.
The macro search in a directory after excel files with certain names and then copy the data to another workbook, this works perfect thanks to the hepf of this forum!
But know, i want that the macro not only copy the data from this folder but als from the subfolders and i struggle to realize that.
I'm really a newbie in VBA, so if anyone could help me with this, that would be great!

Here's my code:

Sub Suchenundkopieren()

Dim directory As String, fileName As String, sheet As Worksheet
Application.ScreenUpdating = False

directory = "C:\Users\YL\Desktop\Test\*"
fileName = Dir(directory & "Quell*.xl*")

Tabelle1.Cells.Clear


    Do While fileName <> ""

    Dim src As Workbook
    Dim lr As Long 'Quelle
    Dim lrZiel As Long 'Ziel
    Dim WsZiel As Worksheet

        Set WsZiel = ThisWorkbook.Worksheets("Tabelle1")

        Set src = Workbooks.Open(directory & fileName, Password:="1234")

        lr = src.Worksheets("Overview").Range("A" & src.Worksheets("Overview").Rows.Count).End(xlUp).Row

        lrZiel = WsZiel.Cells(WsZiel.Rows.Count, 1).End(xlUp).Row
        If lrZiel <> 1 Then lrZiel = lrZiel + 2

        src.Worksheets("Overview").Range("A1:MV" & lr).Copy Destination:=WsZiel.Cells(lrZiel, 1)

    src.Close False

    Set src = Nothing
    Set WsZiel = Nothing

    fileName = Dir

    Loop

Application.ScreenUpdating = True

End Sub

Greetings

Code Tags Added
Your post does not comply with Rule 2 of our Forum RULES. Use code tags around code.

Posting code between [CODE] [/CODE] tags makes your code much easier to read and copy for testing, it also maintains VBA formatting.

Highlight your code and click the # icon at the top of your post window. More information about these and other tags can be found at http://www.excelforum.com/forum-rule...rum-rules.html



(I have added them for you today. Please take a few minutes to read all Forum Rules and comply in the future.)

Maybe like this

Sub aa()
Dim fso as object,sf as object,v as object
Dim ff as object
Set fso = CreateObject("scripting.fileSystemObject")
Set sf = fso.getFolder("c:\mydoc\")
  For each ff in sf.subfolders
      Set ff = sf
   
         For each v in ff.files
             Msgbox v.name
              'do somethink
         Next v
  Next ff
End sub

I've tried to implement it but i just get som error notification. Could you tell me what is wrong?

Here's my modified code:

Sub Suchenundkopieren()

Dim directory As String, fileName As String, sheet As Worksheet
Dim fso As Object, sf As Object, v As Object, ff As Object

Application.ScreenUpdating = False

directory = "C:\Users\YL\Test\*"
fileName = Dir(directory & "Quell*.xl*")

Tabelle1.Cells.Clear
   Set sf = fso.getFolder("C:\Users\YL\Test\")
   For Each ff In sf.subfolders
   Set ff = sf
        Do While fileName <> ""

        Dim src As Workbook
        Dim lr As Long 'Quelle
        Dim lrZiel As Long 'Ziel
        Dim WsZiel As Worksheet

            Set WsZiel = ThisWorkbook.Worksheets("Tabelle1")

            Set src = Workbooks.Open(directory & fileName, Password:="1a2b3c4d")

            lr = src.Worksheets("Overview").Range("A" & src.Worksheets("Overview").Rows.Count).End(xlUp).Row

            lrZiel = WsZiel.Cells(WsZiel.Rows.Count, 1).End(xlUp).Row
            If lrZiel <> 1 Then lrZiel = lrZiel + 2

            src.Worksheets("Overview").Range("A1:MV" & lr).Copy Destination:=WsZiel.Cells(lrZiel, 1)

        src.Close False

        Set src = Nothing
        Set WsZiel = Nothing

        fileName = Dir

        Loop
    Next ff
    
Application.ScreenUpdating = True

End Sub

TRY THIS

Sub wBopEN()
Dim fso As Object, f As Object, sf As Object, ssf As Object, myFile As Object
Dim WB As Workbook, j As Long, n As Long, i As Long, x(), mytable
Set fso = CreateObject("Scripting.filesystemObject")
Set f = fso.GetFolder("C:\Users\YL\Test\")  'THIS IS MAIN FOLDER

Application.ScreenUpdating = False
For Each sf In f.SubFolders
Set ssf = sf
    For Each myFile In ssf.Files
       If myFile.Name Like "Quell*.xl*" Then
          MsgBox myFile.Name
          Set WB = Workbooks.Open(myFile, False)
            With WB.Sheets("Overview")
                   lr = .Worksheets("Overview").Range("A" & .Worksheets("Overview").Rows.Count).End(xlUp).Row
                   .Worksheets("Overview").Range("A1:MV" & lr).Copy ThisWorkbook.Worksheets("Tabelle1").Cells(Rows.Count, 1).End(3)(2)
             .Parent.Close savechanges:=False
            End With
       End If
    Next myFile, sf
Application.ScreenUpdating = True
End Sub

First yo must select main folder
Folder a contain sub folder 1 and folder 2
Your path must select
"c:\blallalal\a\"
Its work for me

lr = .Worksheets("Overview").Range("A" & .Worksheets("Overview").Rows.Count).End(xlUp).Row

Change to

.Worksheets("Overview").columns(1).specialcells(11).row

daboho,

Please don't quote whole posts -- it's just clutter. If you are responding to a post out of sequence, limit quoted content to a few relevant lines that makes clear to whom and what you are responding

For normal conversational replies, try using the QUICK REPLY box below.