Macro to combine multiple (small) files into one file

[sherylt13]

Hello, curious on a macro that would potentially bring information together on one spreadsheet. There will be a few hundred small spreadsheets, all exactly the same, that we need to bring together into one list, to essentially be a data dump of all information. This includes each single file as it's own line on the final spreadsheet. I attached four spreadsheets that mirror the single files, along with a final file, which is the desired result.

Each of the single files would be located on a shared drive in the same folder location. Any suggestions on how to make this work?

Thanks so much.
Sheryl

[mike7952]

This will work. Change the code highlighted in red. Path to files. Also sheet name, I'm assuming it'll be named sheet1. Also assumes these will be the only files in the folder.

Sub ImportSheet()
 Const MGR_NAME As String = "A2"
 Const EMP_NAME As String = "C2"
 Const QUESTIONS As String = "A5"
    Dim i As Long
    Dim SourceFolder As String
    Dim FileList As Variant
    Dim GrabSheet As String
    Dim FileType As String
    Dim ActWorkBk As String
    Dim ImpWorkBk As String
    Dim NoImport As Boolean

    
    'Define folder location (and filetypes)
    SourceFolder = "C:\Users\Mike\Downloads\Test"
    FileType = "*.xlsx"

    'Define sheetname to copy
    GrabSheet = "Sheet1"

    'Creates list with filenames
    FileList = ListFiles(SourceFolder & "/" & FileType)

    'Imports data
    Application.ScreenUpdating = False
    ActWorkBk = ActiveWorkbook.Name
    NoImport = False

    For i = 1 To UBound(FileList)
        'Opens file
        Workbooks.Open (SourceFolder & "\" & FileList(i))
        ImpWorkBk = ActiveWorkbook.Name

        'Checks to see if the specific sheet exists in the workbook
        On Error Resume Next
            ActiveWorkbook.Sheets(GrabSheet).Select
            If Err.Number > 0 Then
                NoImport = True
                GoTo nxt
            End If
            Err.Clear
        On Error GoTo 0

        'Copies questions
        With Workbooks(ActWorkBk).ActiveSheet.Cells(Rows.Count, 1).End(xlUp)
            .Offset(1) = Workbooks(ImpWorkBk).Sheets(GrabSheet).Range(MGR_NAME).Value
            .Offset(1, 1) = Workbooks(ImpWorkBk).Sheets(GrabSheet).Range(EMP_NAME).Value
            .Offset(1, 2).Resize(, 7) = Workbooks(ImpWorkBk).Sheets(GrabSheet).Range(QUESTIONS).Resize(, 7).Value
        End With
        On Error Resume Next
            Err.Clear
        On Error GoTo 0

nxt:
        'Closes importfile
        Workbooks(ImpWorkBk).Activate
        Application.DisplayAlerts = False
        ActiveWorkbook.Saved = True
        ActiveWorkbook.Close SaveChanges:=False
        Application.DisplayAlerts = True
        Workbooks(ActWorkBk).Activate

    Next i

    'Error if some sheets were not found
    If NoImport = True Then MsgBox "One or more sheets could not be found and imported!"

    Application.ScreenUpdating = True
End Sub


'Function that creates an array with all the files in the folder
Function ListFiles(Source As String) As Variant
    Dim GetFileNames() As Variant
    Dim i As Integer
    Dim FileName As String

    On Error GoTo ErrHndlr

    i = 0
    FileName = Dir(Source)
    If FileName = "" Then GoTo ErrHndlr

    'Loops until no more mathing files are found
    Do While FileName <> ""
        i = i + 1
        ReDim Preserve GetFileNames(1 To i)
        GetFileNames(i) = FileName
        FileName = Dir()
    Loop
    ListFiles = GetFileNames
    On Error GoTo 0
    Exit Function

    'If error
ErrHndlr:
    ListFiles = False
    On Error GoTo 0
End Function

[spitfireblue]

Try this - just change myPath to the folder where the individual files are kept:

Sub CopyDataFromFiles()

Dim wbM, wb As Workbook
Dim myPath, myFile, myExt As String
Dim nr, lr As String

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Set wbM = ThisWorkbook
nr = wbM.Sheets(1).Range("A" & wbM.Sheets(1).Rows.Count).End(xlUp).Row + 1
myPath = "C:\temp\Data Files\"
myExt = "*.xls*"
myFile = Dir(myPath & myExtension)

Do While myFile <> ""
    Set wb = Workbooks.Open(Filename:=myPath & myFile)
    wbM.Sheets(1).Range("A" & nr).Value = wb.Sheets(1).Range("A2")
    wbM.Sheets(1).Range("B" & nr).Value = wb.Sheets(1).Range("C2")
    wb.Sheets(1).Range("A5:G5").Copy Destination:=wbM.Sheets(1).Range("C" & nr)
    wb.Close SaveChanges:=False
    nr = nr + 1
    myFile = Dir
Loop

Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

[sherylt13]

Fantastic!!! Thanks so much! Wow those were quick. Appreciate the help, this will be very helpful as we might not have the appropriate technology to support this effort, so this gives us an alternative solution.

Thank you again,
Sheryl

[Marc L]

Hi Sheryl !

Next demonstration code must be in final file worksheet class module
and workbook saved as .xlsb or .xlsm in same single files folder :

Sub Demo1()
    Const E = ";Extended Properties=""Excel 12.0;HDR=No"""
    Dim oCn As Object, P$, F$, R&, V
          P = ThisWorkbook.Path & "\"
          F = Dir(P & "*.xlsx"):  If F = "" Then Beep: Exit Sub
    Me.UsedRange.Offset(1).Clear
    [E2].Value = "     Wait …"
    Application.ScreenUpdating = False
    Set oCn = CreateObject("ADODB.Connection")
          P = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & P
          R = 1
    Do
             oCn.Open P & F & E
        With oCn.Execute("SELECT * FROM [A2:G5]")
            V = .GetRows
                .Close
        End With
             oCn.Close
          R = R + 1
          Cells(R, 1).Resize(, 9).Value = Array(V(0, 0), V(2, 0), V(0, 3), V(1, 3), V(2, 3), V(3, 3), V(4, 3), V(5, 3), V(6, 3))
          F = Dir
    Loop Until F = ""
    Set oCn = Nothing
    Application.ScreenUpdating = True
End Sub 

Do you like it ? So thanks to click on bottom left star icon « ★ Add Reputation » !