Transfer data from several workbooks to the main one

S

sofas

Well-known Member
Joined
Sep 11, 2022
Messages
559
Office Version
  1. 2021
  2. 2019
Platform
  1. Windows
Hello. I have this code to fetch data from several workbooks, provided that the name of the sheet and the name of the workbook are from within any folder. It works fine. I want to modify it so that I can fetch data from several folders. Sometimes I have a folder that contains 6 or 7 folders, with several workbooks inside each folder. How can I once I select the home folder.it searches all folders for data

Code: 
Sub ImportFiles()
Dim strPath As String, xStrPath As String, xStrName As String, xStrFName As String
Dim xWS As Worksheet, xTWB As Workbook, WSdest As Worksheet, FileName As String
Dim xStrAWBName As String, Sh1 As Worksheet, FolderName As String, sItem As String
Dim FolderPath As String, fldr As FileDialog, Lr As Long, Lc As Long, Lr2 As Long
On Error Resume Next
ActiveSheet.Cells.Clear
Set xTWB = ThisWorkbook
Set WSdest = xTWB.ActiveSheet
Debug.Print WSdest.Name
  Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:

    FolderName = sItem
    Set fldr = Nothing
    FolderPath = FolderName & "\"

FileName = Dir(FolderPath & "*data*.xls*")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Do While FileName <> ""
Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
xStrAWBName = ActiveWorkbook.Name
Set Sh1 = ActiveWorkbook.Sheets("Sheet1")
xStrName = Sh1.Name
For Each xWS In ActiveWorkbook.Sheets
If xWS.Name = xStrName Then
Lr = WSdest.Range("A:Z").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Lr2 = xWS.Range("A:Z").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Lc = Cells(1, Columns.Count).End(xlToLeft).Column
If Lr = 1 Then
Range(xWS.Cells(1, 1), xWS.Cells(Lr2, Lc)).Copy WSdest.Range("A1")
Else
Range(xWS.Cells(2, 1), xWS.Cells(Lr2, Lc)).Copy WSdest.Range("A" & Lr + 1)
End If
End If
Next xWS
Workbooks(xStrAWBName).Close
FileName = Dir()
Loop
xTWB.Save
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
 

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.
Sort by date Sort by votes
i don't test this yet but try this:
VBA Code: 
Sub Main() 'choose parent folder that include all sub folder that you need to get data from
    Dim fldr As FileDialog
    Dim FolderPath As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then Exit Sub
        FolderPath = .SelectedItems(1) & "\"
    End With
    Call LoopThroughFolders(FolderPath)
End Sub

Private Sub LoopThroughFolders(ByVal xFol As String) 'loop to get parent folder path and all sub folders in parent folder
    Dim FolderPath As String, subFolderPath As String
    Dim xFSO As Object
    Dim xFolder As Object
    Dim xSubFolder As Object
    Call ImportFiles(xFol) 'call sub import for each folder
    Set xFSO = CreateObject("Scripting.FileSystemObject")
    Set xFolder = xFSO.GetFolder(xFol)
    For Each xSubFolder In xFolder.SubFolders
        subFolderPath = xSubFolder.Path & "\"
        Call LoopThroughFolders(subFolderPath)
    Next xSubFolder
    Set xFile = Nothing
    Set xFolder = Nothing
    Set xFSO = Nothing
End Sub

Private Sub ImportFiles(ByVal FolderPath As String)
    Dim strPath As String, xStrPath As String, xStrName As String, xStrFName As String
    Dim xWS As Worksheet, xTWB As Workbook, WSdest As Worksheet, FileName As String
    Dim xStrAWBName As String, Sh1 As Worksheet, FolderName As String, sItem As String
    Dim fldr As FileDialog, Lr As Long, Lc As Long, Lr2 As Long
    On Error Resume Next
    ActiveSheet.Cells.Clear
    Set xTWB = ThisWorkbook
    Set WSdest = xTWB.ActiveSheet
    FileName = Dir(FolderPath & "*data*.xls*")
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    Do While FileName <> ""
        Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
        xStrAWBName = ActiveWorkbook.Name
        Set Sh1 = ActiveWorkbook.Sheets("Sheet1")
        xStrName = Sh1.Name
        For Each xWS In ActiveWorkbook.Sheets
            If xWS.Name = xStrName Then
                Lr = WSdest.Range("A:Z").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                Lr2 = xWS.Range("A:Z").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                Lc = Cells(1, Columns.Count).End(xlToLeft).Column
                If Lr = 1 Then
                    Range(xWS.Cells(1, 1), xWS.Cells(Lr2, Lc)).Copy WSdest.Range("A1")
                Else
                    Range(xWS.Cells(2, 1), xWS.Cells(Lr2, Lc)).Copy WSdest.Range("A" & Lr + 1)
                End If
            End If
        Next xWS
        Workbooks(xStrAWBName).Close
        FileName = Dir()
    Loop
    xTWB.Save
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
End Sub

with this code, you need to run from Main() sub
 
Upvote 0
Solution
eiloken said:
i don't test this yet but try this:
VBA Code: 
Sub Main() 'choose parent folder that include all sub folder that you need to get data from
    Dim fldr As FileDialog
    Dim FolderPath As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then Exit Sub
        FolderPath = .SelectedItems(1) & "\"
    End With
    Call LoopThroughFolders(FolderPath)
End Sub

Private Sub LoopThroughFolders(ByVal xFol As String) 'loop to get parent folder path and all sub folders in parent folder
    Dim FolderPath As String, subFolderPath As String
    Dim xFSO As Object
    Dim xFolder As Object
    Dim xSubFolder As Object
    Call ImportFiles(xFol) 'call sub import for each folder
    Set xFSO = CreateObject("Scripting.FileSystemObject")
    Set xFolder = xFSO.GetFolder(xFol)
    For Each xSubFolder In xFolder.SubFolders
        subFolderPath = xSubFolder.Path & "\"
        Call LoopThroughFolders(subFolderPath)
    Next xSubFolder
    Set xFile = Nothing
    Set xFolder = Nothing
    Set xFSO = Nothing
End Sub

Private Sub ImportFiles(ByVal FolderPath As String)
    Dim strPath As String, xStrPath As String, xStrName As String, xStrFName As String
    Dim xWS As Worksheet, xTWB As Workbook, WSdest As Worksheet, FileName As String
    Dim xStrAWBName As String, Sh1 As Worksheet, FolderName As String, sItem As String
    Dim fldr As FileDialog, Lr As Long, Lc As Long, Lr2 As Long
    On Error Resume Next
    ActiveSheet.Cells.Clear
    Set xTWB = ThisWorkbook
    Set WSdest = xTWB.ActiveSheet
    FileName = Dir(FolderPath & "*data*.xls*")
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    Do While FileName <> ""
        Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
        xStrAWBName = ActiveWorkbook.Name
        Set Sh1 = ActiveWorkbook.Sheets("Sheet1")
        xStrName = Sh1.Name
        For Each xWS In ActiveWorkbook.Sheets
            If xWS.Name = xStrName Then
                Lr = WSdest.Range("A:Z").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                Lr2 = xWS.Range("A:Z").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                Lc = Cells(1, Columns.Count).End(xlToLeft).Column
                If Lr = 1 Then
                    Range(xWS.Cells(1, 1), xWS.Cells(Lr2, Lc)).Copy WSdest.Range("A1")
                Else
                    Range(xWS.Cells(2, 1), xWS.Cells(Lr2, Lc)).Copy WSdest.Range("A" & Lr + 1)
                End If
            End If
        Next xWS
        Workbooks(xStrAWBName).Close
        FileName = Dir()
    Loop
    xTWB.Save
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
End Sub

with this code, you need to run from Main() sub
Click to expand...
Thank you. The process was completed successfully. If you want to specify the location or path of the main folder that includes the subfolders within the code without showing the selection window. What can I change?
 
Upvote 0
sofas said:
Thank you. The process was completed successfully. If you want to specify the location or path of the main folder that includes the subfolders within the code without showing the selection window. What can I change?
Click to expand...
then you can change main() sub like this:
VBA Code: 
Sub Main() 'choose parent folder that include all sub folder that you need to get data from
    Dim FolderPath As String
    FolderPath = "your parent folder path"
    Call LoopThroughFolders(FolderPath)
End Sub
 
Upvote 0
eiloken said:
then you can change main() sub like this:
VBA Code: 
Sub Main() 'choose parent folder that include all sub folder that you need to get data from
    Dim FolderPath As String
    FolderPath = "your parent folder path"
    Call LoopThroughFolders(FolderPath)
End Sub
Click to expand...

Thank you, I appreciate your effort with me. Last inquiry please. Is it possible to replace the file name here with the value of a specific cell, for example, because I use the file to merge several different workbooks, so that the change is in the cell without entering the code and modifying it?

FileName = Dir(FolderPath & "*data*.xls*")
 
Upvote 0
sofas said:
Thank you, I appreciate your effort with me. Last inquiry please. Is it possible to replace the file name here with the value of a specific cell, for example, because I use the file to merge several different workbooks, so that the change is in the cell without entering the code and modifying it?

FileName = Dir(FolderPath & "*data*.xls*")
Click to expand...
i don't really get your point, you can change file name to value of cell but that mean the cell value will include file path, in that case, we don't need to loop through each subfolder in parent folder right?
 
Upvote 0
eiloken said:
i don't really get your point, you can change file name to value of cell but that mean the cell value will include file path, in that case, we don't need to loop through each subfolder in parent folder right?
Click to expand...

I mean, I have 3 types of workbooks on the data, employee, and transport folders, with numbering. If I want to merge, for example, employee files, I have to enter the code and replace the word data so that it becomes like this

FileName = Dir(FolderPath & "*employee*.xls*")

What I want is to type the desired name in a specific cell only
 
Upvote 0
in that case, you can change it like this:
VBA Code: 
FileName = Dir(FolderPath & "*" & ActiveSheet.Cells(1, 1) & "*.xls*") 'change ActiveSheet.Cells(1, 1) to the cell that has value of file name
 
Upvote 1
You must log in or register to reply here.

Similar threads

J
  • Question Question
Append data to master file
Replies
6
Views
339
Alex Blakenburg
A
G
  • Solved
Change Macro to import files from hyperlinks
2
Replies
12
Views
941
GarnesGambit
G
L
  • Solved
Sheets.("SheetName*") Sheets Wildcard?
Replies
3
Views
795
LocarAce
L
L
  • Solved
Include Filename to Each Row When Importing Multiple Files Data Into 1 Worksheet
Replies
3
Views
698
dmt32
D
R
  • Solved
combining csv workbooks to single sheet - vba works but need help adjusting
Replies
4
Views
642
Alex Blakenburg
A

Forum statistics

Threads
1,223,958
Messages
6,175,642
Members
452,663
Latest member
MEMEH

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top