Consulting

Results 1 to 3 of 3

Thread: Loop through folder to fill a table

  1. #1

    Loop through folder to fill a table

    I am trying to loop through an entire folder, opening each file in the folder and getting data from the same seven cells in each file and filling a table with the data. The code I have below only takes me to select one file and then fills only the top row of the table.

    Sub Data()
    Set wb1 = ActiveWorkbook
    ChDrive "F"
    ChDir "F:\Stuff\SPECIAL PROJECTS\More Stuff\2018"
    MsgBox ("Select file")
    ret1 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
    , "Please select file")
    If ret1 = False Then Exit Sub
    Application.ScreenUpdating = False
    Set wb2 = Workbooks.Open(ret1)
    On Error Resume Next
    wb1.Sheets("Sheet1").Range("B6").Value = wb2.Sheets("Sheet1").Range("C1").Value
    wb1.Sheets("Sheet1").Range("C6").Value = wb2.Sheets("Sheet1").Range("C2").Value
    wb1.Sheets("Sheet1").Range("D6").Value = wb2.Sheets("Sheet1").Range("C3").Value
    wb1.Sheets("Sheet1").Range("E6").Value = wb2.Sheets("Sheet1").Range("E3").Value
    wb1.Sheets("Sheet1").Range("F6").Value = wb2.Sheets("Sheet1").Range("C27").Value
    wb1.Sheets("Sheet1").Range("G6").Value = wb2.Sheets("Sheet1").Range("D27").Value
    wb1.Sheets("Sheet1").Range("H6").Value = wb2.Sheets("Sheet1").Range("E28").Value
    wb2.Close savechanges:=False
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    End Sub

    In the code above, B6:H6 represent the top row of the table, while C1, C2, C3, E3, C27, D27, & E28 contain the data I wish to extract from each file in the folder. I need it to be able to fill the table without taking more than a minute (~400 files in folder).

    Is there a simple way to do this? I was able to do it using a query, but it isn't as neat and clean as I would like.

    I am using Excel 2016.

  2. #2
    Hi eljacinto,

    Try:
    (UNTESTED)

    Come back with any questions.

    ALSO NOTE: You're going to have to enable Microsoft Scripting runtime to use the .fso object.
    Its easy, in the code window, click: Tools > References > 'Check the box "Microsoft Scripting Runtime"'


    Sub Test()
    Application.ScreenUpdating = False
    
    Dim fso As New FileSystemObject ' Enables macro to search file explorer for files
    Dim dataFiles As Variant ' String array that holds the file names
    Dim qwp As Long ' Forloop variable
    Dim WBT As Workbook
    Dim WBD As Workbook
    Dim WPN As Worksheet
    Dim WSD As Worksheet
    dataFiles = Application.GetOpenFilename("data Files(*.), *.)", 1, "Select ALL Desired Files.", "Select", True) ' Gets file names of shift/ctrl clicked files
    
    Set WBT = ThisWorkbook
    Set WPN = WBT.Sheets(1)
    
    ' Initializes counter variable
    Counter = 0
    
    ' Sets counter equal to amount of dataFiles chosen
    For qwp = LBound(dataFiles) To UBound(dataFiles)
        Counter = Counter + 1
    Next qwp
    
    'Execute for every sample
    For m = 1 To Counter
    
    
        ' Open Workbook with m'th string name from dataFiles string array
        dataWorkbookFileName = fso.GetFileName(dataFiles(m)) ' Gets filename of file
        Workbooks.Open dataFiles(m) ' Opens dataFile Workbook
        
        Set WBD = Workbooks(dataWorkbookFileName)
        Set WSD = WBD.Sheets(1)
        
        Dim cArr(), rVal1 As Variant, rVal2 As Variant, rVal3 As Variant, rVal4 As Variant
        With WSD
            cArr = Range(.Cells(1, 3), .Cells(3, 3)).Value
            rVal1 = .[E3].Value
            rVal2 = .[C27].Value
            rVal3 = .[D27].Value
            rVal4 = .[E28].Value
        End With
        With WPN
            .Cells(m + 5, 2).Value = cArr(1, 1)
            .Cells(m + 5, 3).Value = cArr(2, 1)
            .Cells(m + 5, 4).Value = cArr(3, 1)
            .Cells(m + 5, 5).Value = rVal1
            .Cells(m + 5, 6).Value = rVal2
            .Cells(m + 5, 7).Value = rVal3
            .Cells(m + 5, 8).Value = rVal4
        End With
        
        Application.DisplayAlerts = False
        WBD.Close
        Application.DisplayAlerts = True
        
    Next m
    Application.ScreenUpdating = True
    End Sub
    Last edited by mattreingold; 08-15-2018 at 12:45 PM.

  3. #3
    Also, I forgot to mention. Using the above code you can shift-click or crtl-click all the files in the folder, so you can uninclude any you need to.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •