browse to folders and subfolders an copy cell

[KlausW]

Hi

I use this VBA code to browse folders and copy cells to a sheet.

It works really well.

Now I would like to think that it also looked in all the subfolders.

The folder it must look in is called D:\Frihedsansøgning\Dato\ under which there are many subfolders with files.

Some who can help

Any help will be appreciated

Best Regards

Klaus W

Sub Macro33()

  Dim sourceFolder As String
    Dim sourceFiles As Object
    Dim sourceFile As Object
    Dim wbSource As Workbook
    Dim wsDestination As Worksheet
    Dim destinationRow As Long
    
Application.ScreenUpdating = False
Application.DisplayAlerts = False

    ' Set the path to the source folder modify accordingly
    sourceFolder = "D:\Frihedsansøgning\Dato\"
    
    ' Set the destination worksheet modify sheet name accordingly
    Set wsDestination = ThisWorkbook.Worksheets("Måned")
    
    ' Initialize the destination row
    destinationRow = 1
    
    ' Create a FileSystemObject to work with files in the folder
    Set sourceFiles = CreateObject("Scripting.FileSystemObject").GetFolder(sourceFolder).Files
    
    ' Loop through each file in the folder
    For Each sourceFile In sourceFiles
        ' Check if the file is an Excel file
        If sourceFile.Name Like "*.xlsx" Then
            ' Open the source workbook
            Set wbSource = Workbooks.Open(sourceFile.Path)
            
            ' Copy the values from B4 to B7
            wbSource.Worksheets(1).Range("o1:q1").Copy
            
            ' Paste the values to the destination worksheet
            wsDestination.Range("S" & destinationRow).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
           
            ' Update the destination row for the next set of values
            destinationRow = destinationRow + 1
            
            ' Close the source workbook without saving changes
            wbSource.Close SaveChanges:=False
        End If
    Next sourceFile
    
    ' Clear the clipboard
    Application.CutCopyMode = False
    
    ' Display a message when the copying is complete
    'MsgBox "Copying customer information from files complete."

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub