Copy data from workbooks in a folder to one master workbook

[jayn309]

Hi. I have data in multiple workbooks in a folder with the same template and I need to extract those circled data into one master workbook as below

I have a code to loop thru all the workbooks in the folder but I do not know how to do the data copying/extracting. Thank you for any help!.

Sub LoopAllFilesInAFolder()

'Loop through all files in a folder
Dim fileName As Variant
fileName = Dir("C:\Users\Student\Documents\6004*")

While fileName <> ""
    
    'Insert the actions to be performed on each file
    
Wend

End Sub

 

[jayn309]

You must not be aware that Power Query is made for this kind of task. You can pull all Excel Workbooks into one query (Get Data From Folder), and combine then into a single worksheet.
Once done, when new Workbooks are added to the folder, all that's needed is to hit Refresh All to update the master Worksheet.

Thank you for your suggesting. I didn't think of Power Query nor know much about it. Do you know if I can get data from Excel Workbooks in different folders using Power Query as do what you suggested?

 

[Skyybot]

@mumps , I am a VBA novice. Could you tell me why one would choose the expression [If x <> ""] over [If x = IsNothing]? Is there a diffenrence? If so, what is it?

 

[jayn309]

is there any way I can modify the to loop to subfolders of a given directory to get the excel files with a specific name format i.e 600*.xlsx and do the copy task? Thank you.

 

[jdellasala]

is there any way I can modify the to loop to subfolders of a given directory to get the excel files with a specific name format i.e 600*.xlsx and do the copy task? Thank you.

Power Query pulls in all the files in the specified folder as well as all sub folders. That is presented in a table where you can easily filter the files by filename, extension, or folder. It can handle any number of files, and should the data exceed the one million row limit of Excel itself, can load the data into what's called the Data Model which can then be used to create Pivot Table or Pivot Chart reports.
There are lots of Excel channels on YouTube with Playlists on Power Query. I would recommend this Playlist, as well as this one. Don't be overwhelmed by the number of videos. Power Query is very easy to use and learning the basics is quick and easy. And there's always help available here!

 

[mumps]

@*Skyybot
Check out these links:
Information.IsNothing(Object) Method (Microsoft.VisualBasic)
IsEmpty function (Visual Basic for Applications)

 

[mumps]

Change the path of the given directory (in red) to suit your needs. Please note that the macro will not open files in the given directory, only in its subfolders.

Sub CopyData()
    Application.ScreenUpdating = False
    Dim FSO As Object, fld As Object, fsoFile As Object, fsoFol As Object, folderPath As String
    Dim wsDest As Worksheet, wsSource As Worksheet, i As Long, v As Variant, arr() As Variant, cnt As Long
    Set wsDest = ThisWorkbook.Sheets("Sheet1")
    With wsDest
        .Range("A2:M" & .Cells(.Rows.Count, "A").End(xlDown).Row).ClearContents
    End With
    folderPath = "C:\Test\" ' change the path to match the path of your main folder
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set fld = FSO.GetFolder(folderPath)
    If FSO.FolderExists(fld) Then
         For Each fsoFol In FSO.GetFolder(folderPath).SubFolders
            For Each fsoFile In fsoFol.Files
                If fsoFile.Name Like "600*.xlsx" Then 'change the file name to match the name of your source file
                    Workbooks.Open (fsoFile.Path)
                    With ActiveWorkbook
                        Set wsSource = .Sheets(1)
                        v = wsSource.Range("D5:D13").Value
                        For i = LBound(v) To UBound(v)
                            If v(i, 1) <> "" Then
                                cnt = cnt + 1
                                ReDim Preserve arr(1 To cnt)
                                arr(cnt) = v(i, 1)
                            End If
                        Next i
                        With wsDest
                            .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 5).Value = arr
                            .Cells(.Rows.Count, "F").End(xlUp).Offset(1).Resize(, 7).Value = Application.Transpose(wsSource.Range("P9:P15"))
                            .Cells(.Rows.Count, "M").End(xlUp).Offset(1).Value = wsSource.Range("O16").Value
                        End With
                        cnt = 0
                        .Close savechanges:=False
                    End With
                End If
            Next fsoFile
         Next fsoFol
    End If
    Application.ScreenUpdating = True
End Sub

 

[jayn309]

Change the path of the given directory (in red) to suit your needs. Please note that the macro will not open files in the given directory, only in its subfolders.

Sub CopyData()
    Application.ScreenUpdating = False
    Dim FSO As Object, fld As Object, fsoFile As Object, fsoFol As Object, folderPath As String
    Dim wsDest As Worksheet, wsSource As Worksheet, i As Long, v As Variant, arr() As Variant, cnt As Long
    Set wsDest = ThisWorkbook.Sheets("Sheet1")
    With wsDest
        .Range("A2:M" & .Cells(.Rows.Count, "A").End(xlDown).Row).ClearContents
    End With
    folderPath = "C:\Test\" ' change the path to match the path of your main folder
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set fld = FSO.GetFolder(folderPath)
    If FSO.FolderExists(fld) Then
         For Each fsoFol In FSO.GetFolder(folderPath).SubFolders
            For Each fsoFile In fsoFol.Files
                If fsoFile.Name Like "600*.xlsx" Then 'change the file name to match the name of your source file
                    Workbooks.Open (fsoFile.Path)
                    With ActiveWorkbook
                        Set wsSource = .Sheets(1)
                        v = wsSource.Range("D5:D13").Value
                        For i = LBound(v) To UBound(v)
                            If v(i, 1) <> "" Then
                                cnt = cnt + 1
                                ReDim Preserve arr(1 To cnt)
                                arr(cnt) = v(i, 1)
                            End If
                        Next i
                        With wsDest
                            .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 5).Value = arr
                            .Cells(.Rows.Count, "F").End(xlUp).Offset(1).Resize(, 7).Value = Application.Transpose(wsSource.Range("P9:P15"))
                            .Cells(.Rows.Count, "M").End(xlUp).Offset(1).Value = wsSource.Range("O16").Value
                        End With
                        cnt = 0
                        .Close savechanges:=False
                    End With
                End If
            Next fsoFile
         Next fsoFol
    End If
    Application.ScreenUpdating = True
End Sub

Hi! This code works well for the 1st level of subfolders from the given directory, but there are subfolders in some of those subfolders too and as I searched online, I would need a recursive function to do it? How would I modify your code to do that? Thank you.

 

[mumps]

Please note that there are two macros and RunMeFirst calls the second macro. Change the file path (in red) to suit your needs. Also, this code will open any appropriate files in the given directory.

Sub RunMeFirst()
    Application.ScreenUpdating = False
    Dim FileSystem As Object, HostFolder As String
    HostFolder = "C:\Test\"
    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    CopyData FileSystem.GetFolder(HostFolder)
    Application.ScreenUpdating = True
End Sub

Sub CopyData(Folder)
    Application.ScreenUpdating = False
    Dim FSO As Object, fld As Object, fsoFile As Object, fsoFol As Object, folderPath As String, srcWB As Workbook
    Dim wsDest As Worksheet, wsSource As Worksheet, i As Long, v As Variant, arr() As Variant, cnt As Long, SubFolder, File
    Set wsDest = ThisWorkbook.Sheets("Sheet1")
    With wsDest
        .Range("A2:M" & .Cells(.Rows.Count, "A").End(xlDown).Row).ClearContents
    End With
    For Each SubFolder In Folder.SubFolders
        CopyData SubFolder
    Next SubFolder
    For Each File In Folder.Files
        If File.Name Like "600*.xlsx" Then 'change the file name to match the name of your source file
            Set srcWB = Workbooks.Open(Filename:=File)
            With ActiveWorkbook
                Set wsSource = .Sheets(1)
                v = wsSource.Range("D5:D13").Value
                For i = LBound(v) To UBound(v)
                    If v(i, 1) <> "" Then
                        cnt = cnt + 1
                        ReDim Preserve arr(1 To cnt)
                        arr(cnt) = v(i, 1)
                    End If
                Next i
                With wsDest
                    .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 5).Value = arr
                    .Cells(.Rows.Count, "F").End(xlUp).Offset(1).Resize(, 7).Value = Application.Transpose(wsSource.Range("P9:P15"))
                    .Cells(.Rows.Count, "M").End(xlUp).Offset(1).Value = wsSource.Range("O16").Value
                End With
                cnt = 0
                .Close savechanges:=False
            End With
        End If
    Next File
    Application.ScreenUpdating = True
End Sub

 

[jayn309]

Hi. The updated code only open and do tasks on some files when I tested it with several directory. You have any idea what would be the issue?

Please note that there are two macros and RunMeFirst calls the second macro. Change the file path (in red) to suit your needs. Also, this code will open any appropriate files in the given directory.

Sub RunMeFirst()
    Application.ScreenUpdating = False
    Dim FileSystem As Object, HostFolder As String
    HostFolder = "C:\Test\"
    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    CopyData FileSystem.GetFolder(HostFolder)
    Application.ScreenUpdating = True
End Sub

Sub CopyData(Folder)
    Application.ScreenUpdating = False
    Dim FSO As Object, fld As Object, fsoFile As Object, fsoFol As Object, folderPath As String, srcWB As Workbook
    Dim wsDest As Worksheet, wsSource As Worksheet, i As Long, v As Variant, arr() As Variant, cnt As Long, SubFolder, File
    Set wsDest = ThisWorkbook.Sheets("Sheet1")
    With wsDest
        .Range("A2:M" & .Cells(.Rows.Count, "A").End(xlDown).Row).ClearContents
    End With
    For Each SubFolder In Folder.SubFolders
        CopyData SubFolder
    Next SubFolder
    For Each File In Folder.Files
        If File.Name Like "600*.xlsx" Then 'change the file name to match the name of your source file
            Set srcWB = Workbooks.Open(Filename:=File)
            With ActiveWorkbook
                Set wsSource = .Sheets(1)
                v = wsSource.Range("D5:D13").Value
                For i = LBound(v) To UBound(v)
                    If v(i, 1) <> "" Then
                        cnt = cnt + 1
                        ReDim Preserve arr(1 To cnt)
                        arr(cnt) = v(i, 1)
                    End If
                Next i
                With wsDest
                    .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 5).Value = arr
                    .Cells(.Rows.Count, "F").End(xlUp).Offset(1).Resize(, 7).Value = Application.Transpose(wsSource.Range("P9:P15"))
                    .Cells(.Rows.Count, "M").End(xlUp).Offset(1).Value = wsSource.Range("O16").Value
                End With
                cnt = 0
                .Close savechanges:=False
            End With
        End If
    Next File
    Application.ScreenUpdating = True
End Sub

 

[mumps]

Check to make sure that all the file names start with "600" and have an "xlsx" extension.