VBA - Open Files then copy specific cells into a new row.

[dhubz]

Hello,
I have about a hundred xlsx files in the same folder, they are identical as far as structure other than the name. I need a VBA to open each file in a folder, unmerge(due to previous formatting) all cells. Then copy specific cells into a new row. Then open the next file and create a new row, until it goes through all of the files.

From each workbook in the folder, I have about 10 cells I need to pull across, here is a sample of the mapping.
Copy H8 to A2
Copy S9 to B2
Copy AK to C2
etc.
Then next file would write to row 3
Copy H8 to A3
Copy S9 to B3
Copy AK to C3
etc.
Thanks for the help.

 

[dhubz]

This works perfect

Sub ProcessFiles()
    Dim FldrPath As String
    Dim Fldr As Object
    Dim fso As Object
    Dim Fl As Object
    Dim WB As Workbook
    Dim RowCount As Integer

    FldrPath = "C:\test"" ' Change this path to your folder path
  
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set Fldr = fso.GetFolder(FldrPath)

    RowCount = 2 ' Start from row 2

    For Each Fl In Fldr.Files
        If Right(Fl.Name, 4) = "xlsx" Then ' Process only Excel files
            Set WB = Workbooks.Open(Fl.Path)
            With WB.Sheets(1)
                .Cells.UnMerge ' Unmerge all cells
                ThisWorkbook.Sheets("Sheet1").Cells(RowCount, 1).Value = .Range("H8").Value ' Copy H8 to A2, A3, ...
                ThisWorkbook.Sheets("Sheet1").Cells(RowCount, 2).Value = .Range("A13").Value ' Copy A13 to B2, B3, ...
                ThisWorkbook.Sheets("Sheet1").Cells(RowCount, 3).Value = .Range("A11").Value ' Copy A11 to C2, C3, ...
                ThisWorkbook.Sheets("Sheet1").Cells(RowCount, 4).Value = .Range("S13").Value
                ThisWorkbook.Sheets("Sheet1").Cells(RowCount, 5).Value = .Range("S9").Value
                ThisWorkbook.Sheets("Sheet1").Cells(RowCount, 6).Value = .Range("S11").Value
                ThisWorkbook.Sheets("Sheet1").Cells(RowCount, 7).Value = .Range("AK9").Value
                ThisWorkbook.Sheets("Sheet1").Cells(RowCount, 8).Value = .Range("AK11").Value
            End With
            WB.Close SaveChanges:=False
            RowCount = RowCount + 1 ' Move to the next row
        End If
    Next Fl
End Sub