Linking multiple excel workbooks and gathering data in one single sheet

Hi,

I am new to working with VBA and I'm probably trying to do  something above my level of knowledge.
I want to link multiple Excel Workbooks from one folder and gather specific cells (data) in one single sheet.

I got the following code working, but it only gives the output of all files in one workbook, with the value of cells A4: C4.

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 = Workbooks.Add(xlWBATWorksheet).Worksheets(1)


' Modify this folder path to point to the files you want to use.
FolderPath = "C:\Users\603964\Desktop\Test"


' 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("A4:C4")


' 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

now I want to select multiple cells from the files that are in the folder, but here I get stuck.
unfortunately I can not manage to select multiple cells and get them in a format.

The output needs te be something like this:

      A                 B      C     D      E      F      G     H     I       J
1 Filename 1      A9      B9      C9      A10      B10      C10      A42      B42      C42
2 Filename 2      A9      B9      C9      A10      B10      C10      A42      B42      C42
3 Filename 3      A9      B9      C9      A10      B10      C10      A42      B42      C42
4 Filename 4      A9      B9      C9      A10      B10      C10      A42      B42      C42
5 Filename 5      A9      B9      C9      A10      B10      C10      A42      B42      C42
6 Filename 6      A9      B9      C9      A10      B10      C10      A42      B42      C42
7 Filename 7      A9      B9      C9      A10      B10      C10      A42      B42      C42
8 Filename 8      A9      B9      C9      A10      B10      C10      A42      B42      C42
......etc.

Could someone please help me with my challenge?
Freek DoornkampAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Fabrice LambertFabrice LambertCommented:
Eww, what an ugly piece of code .....

Short answer:
You just need to modify the range in the following line (replace A4:C4 by whatever suit your needs):
Set SourceRange = WorkBk.Worksheets(1).Range("A4:C4")

Open in new window

And, can you be more precise about what you call: " multiple cells" ?
0
Freek DoornkampAuthor Commented:
Hi Fabrice,

Thx for your reply! I am not proud of the code, but I have to make a start.

This time I made an example in an Excel file (see attached file).

I have a folder containing 200+ Excel files that have to be read in on a quarterly basis.
Now only a few cells are interesting to me and I would like to have them automatically selected and have the output placed in a new worksheet.

Because  the files are submitted by several people, I want the name of the file in the output. Followed by the desired Cells from that specific file.

Set SourceRange = WorkBk.Worksheets(1).Range("A4:C4")

Open in new window


Where i get stuck is to select multiple data and place it in the correct order (see attached file).
I have tried to expand the range with ";" but this does not work.

Set SourceRange = WorkBk.Worksheets(1).Range("A4:C4; A8:C8...etc")

Open in new window

.

Do you have a better idea for me?
Example-Output-File.xlsx
0
Ejgil HedegaardCommented:
Try this.
I have added folder selection.
If you have a fixed folder, replace BrowseFolderFileDialog("Select A Folder") with the path.
The values can be retrieved directly without setting ranges, so SourceRange and DestRange are removed.
The sample file show the values to start in column C, but in the description it is column B.
I have used column B.

Option Explicit

Sub MergeAllWorkbooks()
    Dim SummarySheet As Worksheet
    Dim FolderPath As String
    Dim NRow As Long
    Dim FileName As String
    Dim WorkBk As Workbook
        
    'Select the folder to use
    FolderPath = BrowseFolderFileDialog("Select A Folder")
    If FolderPath = vbNullString Then
        MsgBox "No Folder Selected"
    Else
        If Right(FolderPath, 1) <> "\" Then
            FolderPath = FolderPath & "\"
        End If
        
        'Avoid screen flicker when the workbooks are opened
        Application.ScreenUpdating = False

        ' Create a new workbook and set a variable to the first sheet.
        Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
                
        ' 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
            
            ' Get the values
            SummarySheet.Range("B" & NRow & ":D" & NRow).Value = WorkBk.Worksheets(1).Range("A9:C9").Value
            SummarySheet.Range("E" & NRow & ":G" & NRow).Value = WorkBk.Worksheets(1).Range("A10:C10").Value
            SummarySheet.Range("H" & NRow & ":J" & NRow).Value = WorkBk.Worksheets(1).Range("A42:C42").Value
            
            ' Increase NRow so that we know where to copy data next.
            NRow = NRow + 1
            
            ' 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 If
End Sub

Function BrowseFolderFileDialog(Title As String) As String
    Dim V As Variant
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = Title
        .Show
        On Error Resume Next
        Err.Clear
        V = .SelectedItems(1)
        If Err.Number <> 0 Then
            V = vbNullString
        End If
    End With
    BrowseFolderFileDialog = CStr(V)
End Function

Open in new window

1

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Freek DoornkampAuthor Commented:
Dear Ejgil Hedegaard,

Many thanks for your update and help!
The code works really good.

I will go through the code to learn how it works.
If I have any questions, can I ask those to you?

Best Regards,

Freek
0
Ejgil HedegaardCommented:
Yes you can.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VB Script

From novice to tech pro — start learning today.