Collecting data from multiple workbooks

DarinCampo

New Member
Joined
Mar 10, 2022
Messages
2
Office Version
  1. 365
Platform
  1. Windows
Good morning!

I have zero experience with VBA scripting so any help would be appreciated. I have multiple workbooks that are set up in the same format and I need to pull data from them into a summary workbook for analysis. The data is all in a sheet called "TM 10.3.1" and I would need a new row with these cells from each workbook:

E2B13B4C4D4B5C5D5B6C6D6B7C7D7B8C8D8B9C9D9

Any help would be appreciated.

Thanks.

Darin
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
Lets start with a BIG assumption, all these workbooks are saved in a single folder (why are we making this assumption, because it is easier to code). Now a few smaller(ish) assumptions: 1) we are working with a clean worksheet at the beginning of calling this code. 2) You don't need headers. 3) Only workbooks we want to pull have the "TM 10.3.1" Tab:
VBA Code:
Sub CollectData()

    ' The name of the tab for which we want information
    Const TabName As String = "MT 10.3.1"
    ' Our path to our workbook repository
    Const RepoPath As String = "C:\Repository\"
       
    ' Setup variables
    Dim Book As Workbook
    Dim FSO As Object
    Dim File As Object
    Dim Row As Long
    
    Set FSO = VBA.Interaction.CreateObject(Class:="Scripting.FileSystemObject")
    For Each File In FSO.GetFolder(RepoPath).Files
        ' Open first file found
        Set Book = Application.Workbooks.Open(Filename:=File.Path)
        ' Attempt to find the information tab we want.
        On Error Resume Next
        Set Sheet = Book.Sheets(Index:=TabName)
        ' No errors means we've found it.
        If Err.Number = 0 Then
            On Error GoTo 0
            ' Adjust our row
            Row = Row + 1
            ' Transfer data
            Me.Range("A" & Row).Value = Sheet.Range("E2").Value
            Me.Range("B" & Row).Value = Sheet.Range("B13").Value
            Me.Range("C" & Row).Value = Sheet.Range("B4").Value
            Me.Range("D" & Row).Value = Sheet.Range("C4").Value
            Me.Range("E" & Row).Value = Sheet.Range("D4").Value
            Me.Range("F" & Row).Value = Sheet.Range("B5").Value
            Me.Range("G" & Row).Value = Sheet.Range("C5").Value
            Me.Range("H" & Row).Value = Sheet.Range("D5").Value
            Me.Range("I" & Row).Value = Sheet.Range("B6").Value
            Me.Range("J" & Row).Value = Sheet.Range("C6").Value
            Me.Range("K" & Row).Value = Sheet.Range("D6").Value
            Me.Range("L" & Row).Value = Sheet.Range("B7").Value
            Me.Range("M" & Row).Value = Sheet.Range("C7").Value
            Me.Range("N" & Row).Value = Sheet.Range("D7").Value
            Me.Range("O" & Row).Value = Sheet.Range("B8").Value
            Me.Range("P" & Row).Value = Sheet.Range("C8").Value
            Me.Range("Q" & Row).Value = Sheet.Range("D8").Value
            Me.Range("R" & Row).Value = Sheet.Range("B9").Value
            Me.Range("S" & Row).Value = Sheet.Range("C9").Value
            Me.Range("T" & Row).Value = Sheet.Range("D9").Value
        End If
        On Error GoTo 0
        ' close out the workbook, we are done with it.
        Book.Close SaveChanges:=False
    Next
End Sub
Please note that this code hasn't been tested, please back up your work before testing new code!!!
 
Upvote 0
Solution
Lets start with a BIG assumption, all these workbooks are saved in a single folder (why are we making this assumption, because it is easier to code). Now a few smaller(ish) assumptions: 1) we are working with a clean worksheet at the beginning of calling this code. 2) You don't need headers. 3) Only workbooks we want to pull have the "TM 10.3.1" Tab:
VBA Code:
Sub CollectData()

    ' The name of the tab for which we want information
    Const TabName As String = "MT 10.3.1"
    ' Our path to our workbook repository
    Const RepoPath As String = "C:\Repository\"
      
    ' Setup variables
    Dim Book As Workbook
    Dim FSO As Object
    Dim File As Object
    Dim Row As Long
   
    Set FSO = VBA.Interaction.CreateObject(Class:="Scripting.FileSystemObject")
    For Each File In FSO.GetFolder(RepoPath).Files
        ' Open first file found
        Set Book = Application.Workbooks.Open(Filename:=File.Path)
        ' Attempt to find the information tab we want.
        On Error Resume Next
        Set Sheet = Book.Sheets(Index:=TabName)
        ' No errors means we've found it.
        If Err.Number = 0 Then
            On Error GoTo 0
            ' Adjust our row
            Row = Row + 1
            ' Transfer data
            Me.Range("A" & Row).Value = Sheet.Range("E2").Value
            Me.Range("B" & Row).Value = Sheet.Range("B13").Value
            Me.Range("C" & Row).Value = Sheet.Range("B4").Value
            Me.Range("D" & Row).Value = Sheet.Range("C4").Value
            Me.Range("E" & Row).Value = Sheet.Range("D4").Value
            Me.Range("F" & Row).Value = Sheet.Range("B5").Value
            Me.Range("G" & Row).Value = Sheet.Range("C5").Value
            Me.Range("H" & Row).Value = Sheet.Range("D5").Value
            Me.Range("I" & Row).Value = Sheet.Range("B6").Value
            Me.Range("J" & Row).Value = Sheet.Range("C6").Value
            Me.Range("K" & Row).Value = Sheet.Range("D6").Value
            Me.Range("L" & Row).Value = Sheet.Range("B7").Value
            Me.Range("M" & Row).Value = Sheet.Range("C7").Value
            Me.Range("N" & Row).Value = Sheet.Range("D7").Value
            Me.Range("O" & Row).Value = Sheet.Range("B8").Value
            Me.Range("P" & Row).Value = Sheet.Range("C8").Value
            Me.Range("Q" & Row).Value = Sheet.Range("D8").Value
            Me.Range("R" & Row).Value = Sheet.Range("B9").Value
            Me.Range("S" & Row).Value = Sheet.Range("C9").Value
            Me.Range("T" & Row).Value = Sheet.Range("D9").Value
        End If
        On Error GoTo 0
        ' close out the workbook, we are done with it.
        Book.Close SaveChanges:=False
    Next
End Sub
Please note that this code hasn't been tested, please back up your work before testing new code!!!
All of those assumptions are correct or could be accomodated. Thanks this is much appreciated!
 
Upvote 0

Forum statistics

Threads
1,213,494
Messages
6,113,986
Members
448,538
Latest member
alex78

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