How can I create a loop of gathering data?

[Joe9238]

Hi,
I have a code as seen below that allows you to select a folder and then pull data from a specific sheet from a specific file type (xlsm). The problem is that my code will only run over the first file in the list. I need the code to repeat so that each piece of data specified is pasted into rows below each other. Also, how can I make it so sub-folders are searched and more than one file type is searched (ie add xlsx to the list too)?

Option Explicit


Public Sub GatherData()
    
    Dim codes As Range, code As Range
    Dim folder As String, fileName As String
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & ""
        .Title = "Please select the folder containing CLIENT QUOTE workbooks"
        .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        folder = .SelectedItems(1) & ""
    End With
        
    With ActiveSheet
        .Range("A1:D1").Value = Array("Quoted By", "Quoted On", "Client Name", "Email Address")
        Set codes = .Range("A2", .Cells(Rows.Count, "A").End(xlUp))    'codes in column z starting in A2
    End With
    
    For Each code In codes
        fileName = Dir(folder & "*" & code.Value & "*.xlsm*")
        If fileName <> vbNullString Then
            code.Offset(0, 0).Value = GetCellValue(folder & fileName, "QUOTE", "B7")
            code.Offset(0, 1).Value = GetCellValue(folder & fileName, "QUOTE", "B8")
            code.Offset(0, 2).Value = GetCellValue(folder & fileName, "QUOTE", "B11")
            code.Offset(0, 3).Value = GetCellValue(folder & fileName, "QUOTE", "B13")
        End If
    Next
    
End Sub


Private Function GetCellValue(ByVal workbookFullName As String, sheetName As String, cellsRange As String) As Variant


    Dim folderPath As String, fileName As String
    Dim arg As String
    
    'Make sure the workbook exists
    
    If Dir(workbookFullName) = "" Then
        GetCellValue = "File " & workbookFullName & " not found"
        Exit Function
    End If
    
    folderPath = Left(workbookFullName, InStrRev(workbookFullName, ""))
    fileName = Mid(workbookFullName, InStrRev(workbookFullName, "") + 1)
        
    arg = "'" & folderPath & "[" & fileName & "]" & sheetName & "'!" & Range(cellsRange).Address(True, True, xlR1C1)
    Debug.Print arg
          
    'Execute Excel 4 Macro with argument to closed workbook
    
    GetCellValue = ExecuteExcel4Macro(arg)
    
            Columns("B:B").Select
    Selection.NumberFormat = "m/d/yyyy"
        Range("A1").Select
        
End Function

 

[Johnny Thunder]

by updating this line, fileName = Dir(folder & "*" & code.Value & "*.xls*") 'Modified here to look at all excel files

The code will look for any excel file type instead of .xlsm only.

 

[Joe9238]

Works! Thanks for the help. Do you know how I can create a loop and have the data paste itself repeatedly?