Need Macro to open a folder and fetch data from Excel files

m_aatif

Board Regular
Joined
Apr 18, 2013
Messages
56
I have a folder at this location

D:\AAtif data\D drive\TEST DATA FOLDER\New folder

This folder contains many files.

In each file there is "sheet1" & "Sheet2", which contain data from cells A4 : D30

I need to prepare a summary. VBA Code should open files and prepare a summary sheet, compling data from all files.

One colums of the summary should show Name of the source file for easy tracking.

Thanks
 

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).
This taken from MSDN.microsoft
Don't have Excel at the moment, but you should be able to make minor modifications for this to do what you require

Code:
Sub MergeAllWorkbooks()
    Dim SummarySheet As Worksheet
    Dim FolderPath As String
    Dim NRow As Long
    Dim FileName As String
    Dim WorkBk As Workbook
    Dim SourceRange As Range
    Dim DestRange As Range
    
    ' Create a new workbook and set a variable to the first sheet.
    Set SummarySheet = ActiveWorkbook.Sheets(1)
    
    ' Modify this folder path to point to the files you want to use.
    FolderPath = "C:\Users\Peter\invoices\"
    
    ' NRow keeps track of where to insert new rows in the destination workbook.
    NRow = 1
    
    ' Call Dir the first time, pointing it to all Excel files in the folder path.
    FileName = Dir(FolderPath & "*.xl*")
    
    ' Loop until Dir returns an empty string.
    Do While FileName <> ""
        ' Open a workbook in the folder
        Set WorkBk = Workbooks.Open(FolderPath & FileName)
        
        ' Set the cell in column A to be the file name.
        SummarySheet.Range("A" & NRow).Value = FileName
        
        ' Set the source range to be A9 through C9.
        ' Modify this range for your workbooks.
        ' It can span multiple rows.
        Set SourceRange = WorkBk.Worksheets(1).Range("A9:C9")
        
        ' Set the destination range to start at column B and
        ' be the same size as the source range.
        Set DestRange = SummarySheet.Range("B" & NRow)
        Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
           SourceRange.Columns.Count)
           
        ' Copy over the values from the source to the destination.
        DestRange.Value = SourceRange.Value
        
        ' Increase NRow so that we know where to copy data next.
        NRow = NRow + DestRange.Rows.Count
        
        ' Close the source workbook without saving changes.
        WorkBk.Close savechanges:=False
        
        ' Use Dir to get the next file name.
        FileName = Dir()
    Loop
    
    ' Call AutoFit on the destination sheet so that all
    ' data is readable.
    SummarySheet.Columns.AutoFit
End Sub
 
Upvote 0
Can you please edit it to do cover two more aspects.

1) It should loop through each sheet of the source file and copy data in the destination file.

2) It should also include a column which shows name of the source sheet from where it is copying data.

Thanks
 
Upvote 0
UNTESTED...

Code:
Sub MergeAllWorkbooks()
Dim SummarySheet As Worksheet, FolderPath As String, NRow As Long, FileName As String
Dim WorkBk As Workbook, SourceRange As Range, DestRange As Range
Set SummarySheet = ActiveWorkbook.Sheets(1)
SummarySheet.Name = "Summary"
FolderPath = "D:\AAtif data\D drive\TEST DATA FOLDER\New folder\"
NRow = 1
FileName = Dir(FolderPath & "*.xl*")
Do While FileName <> ""
    Set WorkBk = Workbooks.Open(FolderPath & FileName)
    SummarySheet.Range("A" & NRow).Value = FileName
    Set SourceRange = WorkBk.Worksheets(1).Range("A4:D30")
    Set DestRange = SummarySheet.Range("B" & NRow)
    Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
       SourceRange.Columns.Count)
    DestRange.Value = SourceRange.Value
    NRow = NRow + DestRange.Rows.Count
    WorkBk.Close savechanges:=False
    FileName = Dir()
Loop
SummarySheet.Columns.AutoFit
End Sub




1) It should loop through each sheet of the source file and copy data in the destination file.
The code provided does that already !!!

2) It should also include a column which shows name of the source sheet from where it is copying data.
The code provided does that already !!!

All you had to do was change the ranges required to suit your needs !!
 
Last edited:
Upvote 0
I believe the code provides the File name in col A v. the sheet name.
 
Upvote 0
It provides file Name in Column A, But does not provide sheet name of the source file. Moreover, It does not loop through each sheet of the source files.

Could you please resolve this issue..

Regards
 
Upvote 0
Hanging on Michael's shirttails, give this a try.
Code:
Sub MergeAllWorkbooks()
Dim SummarySheet As Worksheet, FolderPath As String, NRow As Long, FileName As String
Dim WorkBk As Workbook, SourceRange As Range, DestRange As Range
Set SummarySheet = ActiveWorkbook.Sheets(1)
SummarySheet.Name = "Summary"
FolderPath = "D:\AAtif data\D drive\TEST DATA FOLDER\New folder\"
FileName = Dir(FolderPath & "*.xl*")
Do While FileName <> ""
    Set WorkBk = Workbooks.Open(FolderPath & FileName)
    For Each sh In WorkBk.Sheets
    SummarySheet.Cells(Rows.Count, 1).End(xlUp)(2) = WorkBk.Name & ", " & sh.Name
    WorkBk.Range("A4:D30").Copy SummarySheet.Cells(Rows.Count, 1).End(xlUp).Offstet(, 1)
        WorkBk.Close savechanges:=False
    Next
    FileName = Dir()
Loop
SummarySheet.Columns.AutoFit
End Sub

I did not test this so it could have a glitch. Post back with results.
 
Upvote 0
@JLGWhiz
Thanks for jumping in....I don't have Excel at the moment, so didn't want to make my attempt at resolution worse....:oops:
 
Upvote 0
@JLGWhiz
Thanks for jumping in....I don't have Excel at the moment, so didn't want to make my attempt at resolution worse....:oops:

No problem, mate. Happy to help, but hard to tell if it did any good when they don't respond.
 
Upvote 0
Thanks for your inputs. But the code is not generating desired results. It stops after opening first file with an error.

Would you expert people please help.

Regards
 
Upvote 0

Forum statistics

Threads
1,213,534
Messages
6,114,184
Members
448,554
Latest member
Gleisner2

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