Read data from the same worksheet name in multiple workbooks located in multiple directories/subdirectories

D

ddander54

Board Regular
Joined
Oct 18, 2012
Messages
97
Kindly looking for assistance. I need to loop thru multiple folders/subfolders in drive "C:\MyExcelFiles\ROM\Test\" ( ~400 files that were copied from SharePoint) to read data from a common worksheet name in each workbook. In each workbook that I find with "*ROM*.xlsm", I need to look in the "Details" tab and retrieve the value in D11 and D12 and transpose in the Summary/Master sheet Column A5 and Column B5, copy those values down 25 total rows, then copy C18:D42 (the 25 data rows) and paste values in Summary/Master Column C5:D29, then append the next 25 rows of data from the next workbook, etc....

So in the end I get:

Book1
ABCD
1Find File:*ROM*.xlsm
2From Tab:Details
3Copy/Paste Values
4D11D12C18:C42D18:D42
512345Text NameText14
612345Text NameText236
712345Text NameText32
812345Text NameText412
912345Text NameText52
1012345Text NameText614
1112345Text NameText72
1212345Text NameText81
1312345Text NameText90
1412345Text NameText1070
1512345Text NameText110
1612345Text NameText120
1712345Text NameText130
1812345Text NameText140
1912345Text NameText150
2012345Text NameText160
2112345Text NameText170
2212345Text NameText180
2312345Text NameText199
2412345Text NameText2022
2512345Text NameText215
2612345Text NameText2224
2712345Text NameText2321
2812345Text NameText245
2912345Text NameText2510
3023456Text Name2Text120
3123456Text Name2Text230
32etc…
Sheet1


TIA,
Don
 

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.
Sort by date Sort by votes
Try this macro.
VBA Code: 
Option Explicit

Public Sub Import_Data_From_Workbooks()
        
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    With ThisWorkbook.Worksheets("Summary")
        Import_Data_From_Workbooks_In_Folder "C:\MyExcelFiles\ROM\Test\", .Range("B1").Value, .Range("B2").Value, .Range("A5")
    End With
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    MsgBox "Done"
    
End Sub


Private Function Import_Data_From_Workbooks_In_Folder(folderPath As String, matchFiles As String, fromSheetName As String, destCell As Range) As Long
   
    Static FSO As Object
    Dim Folder As Object, Subfolder As Object, File As Object
    Dim dataWb As Workbook
    Dim n As Long
    
    If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")

    'Process files in this folder
    
    n = 0
    Set Folder = FSO.GetFolder(folderPath)    
    For Each File In Folder.Files
        If LCase(File.Name) Like LCase(matchFiles) Then
            'Copy cell values from data workbook
            Set dataWb = Workbooks.Open(File.Path)
            With dataWb.Worksheets(fromSheetName)
                destCell.Offset(n, 0).Resize(25, 2).Value = Application.Transpose(.Range("D11:D12").Value)
                destCell.Offset(n, 2).Resize(25, 2).Value = .Range("C18:D42").Value
                n = n + 25
            End With
            dataWb.Close False
        End If
    Next
    
    'Process files in subfolders
    
    For Each Subfolder In Folder.SubFolders
        n = n + Import_Data_From_Workbooks_In_Folder(Subfolder.Path, matchFiles, fromSheetName, destCell.Offset(n))
    Next
    
    Import_Data_From_Workbooks_In_Folder = n
    
End Function
 
Upvote 0
Solution
Amazing! Thank you! Works like a champ!

John_w said:
Try this macro.
VBA Code: 
Option Explicit

Public Sub Import_Data_From_Workbooks()
       
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    With ThisWorkbook.Worksheets("Summary")
        Import_Data_From_Workbooks_In_Folder "C:\MyExcelFiles\ROM\Test\", .Range("B1").Value, .Range("B2").Value, .Range("A5")
    End With
   
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
   
    MsgBox "Done"
   
End Sub


Private Function Import_Data_From_Workbooks_In_Folder(folderPath As String, matchFiles As String, fromSheetName As String, destCell As Range) As Long
  
    Static FSO As Object
    Dim Folder As Object, Subfolder As Object, File As Object
    Dim dataWb As Workbook
    Dim n As Long
   
    If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")

    'Process files in this folder
   
    n = 0
    Set Folder = FSO.GetFolder(folderPath)   
    For Each File In Folder.Files
        If LCase(File.Name) Like LCase(matchFiles) Then
            'Copy cell values from data workbook
            Set dataWb = Workbooks.Open(File.Path)
            With dataWb.Worksheets(fromSheetName)
                destCell.Offset(n, 0).Resize(25, 2).Value = Application.Transpose(.Range("D11:D12").Value)
                destCell.Offset(n, 2).Resize(25, 2).Value = .Range("C18:D42").Value
                n = n + 25
            End With
            dataWb.Close False
        End If
    Next
   
    'Process files in subfolders
   
    For Each Subfolder In Folder.SubFolders
        n = n + Import_Data_From_Workbooks_In_Folder(Subfolder.Path, matchFiles, fromSheetName, destCell.Offset(n))
    Next
   
    Import_Data_From_Workbooks_In_Folder = n
   
End Function
Click to expand...
 
Upvote 0
John,

As I said, your code works flawlessly, but I ran into a situation where the users haven't all been using the latest version of the Details sheet, so I am trying to add some conditional code to make it work in either case. Please let me know if I have modified the function correctly and then what would I use to end the If>Else so it if it doesn't find these 2 conditions, it just closes the workbook and goes on to the next?

VBA Code: 
    For Each File In Folder.Files
        If LCase(File.Name) Like LCase(matchFiles) Then
            'Copy cell values from data workbook
            Set dataWb = Workbooks.Open(File.Path)
            With dataWb.Worksheets(fromSheetName)
              If Range("C11") = "PPM/Proposal #" Then
                    destCell.Offset(n, 0).Resize(25, 2).Value = Application.Transpose(.Range("D11:D12").Value)
                    destCell.Offset(n, 2).Resize(25, 2).Value = .Range("C18:D42").Value
                    n = n + 25
               ElseIf Range("A11") = "PPM/Proposal #" Then
                    destCell.Offset(n, 0).Resize(25, 2).Value = Application.Transpose(.Range("B11:B12").Value)
                    destCell.Offset(n, 2).Resize(25, 2).Value = .Range("A18:B42").Value
                    n = n + 25
                Else
                'What would go here?'
                End If
            End With
            dataWb.Close False
        End If
    Next

John_w said:
Try this macro.
VBA Code: 
Option Explicit

Public Sub Import_Data_From_Workbooks()
      
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
  
    With ThisWorkbook.Worksheets("Summary")
        Import_Data_From_Workbooks_In_Folder "C:\MyExcelFiles\ROM\Test\", .Range("B1").Value, .Range("B2").Value, .Range("A5")
    End With
  
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
  
    MsgBox "Done"
  
End Sub


Private Function Import_Data_From_Workbooks_In_Folder(folderPath As String, matchFiles As String, fromSheetName As String, destCell As Range) As Long
 
    Static FSO As Object
    Dim Folder As Object, Subfolder As Object, File As Object
    Dim dataWb As Workbook
    Dim n As Long
  
    If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")

    'Process files in this folder
  
    n = 0
    Set Folder = FSO.GetFolder(folderPath)  
    For Each File In Folder.Files
        If LCase(File.Name) Like LCase(matchFiles) Then
            'Copy cell values from data workbook
            Set dataWb = Workbooks.Open(File.Path)
            With dataWb.Worksheets(fromSheetName)
                destCell.Offset(n, 0).Resize(25, 2).Value = Application.Transpose(.Range("D11:D12").Value)
                destCell.Offset(n, 2).Resize(25, 2).Value = .Range("C18:D42").Value
                n = n + 25
            End With
            dataWb.Close False
        End If
    Next
  
    'Process files in subfolders
  
    For Each Subfolder In Folder.SubFolders
        n = n + Import_Data_From_Workbooks_In_Folder(Subfolder.Path, matchFiles, fromSheetName, destCell.Offset(n))
    Next
  
    Import_Data_From_Workbooks_In_Folder = n
  
End Function
Click to expand...
 
Upvote 0
Well that was easy! I just gave it a try as is and it seemed to work fine.....I just let the End If go on to End With and Close the workbook

ddander54 said:
John,

As I said, your code works flawlessly, but I ran into a situation where the users haven't all been using the latest version of the Details sheet, so I am trying to add some conditional code to make it work in either case. Please let me know if I have modified the function correctly and then what would I use to end the If>Else so it if it doesn't find these 2 conditions, it just closes the workbook and goes on to the next?

VBA Code: 
    For Each File In Folder.Files
        If LCase(File.Name) Like LCase(matchFiles) Then
            'Copy cell values from data workbook
            Set dataWb = Workbooks.Open(File.Path)
            With dataWb.Worksheets(fromSheetName)
              If Range("C11") = "PPM/Proposal #" Then
                    destCell.Offset(n, 0).Resize(25, 2).Value = Application.Transpose(.Range("D11:D12").Value)
                    destCell.Offset(n, 2).Resize(25, 2).Value = .Range("C18:D42").Value
                    n = n + 25
               ElseIf Range("A11") = "PPM/Proposal #" Then
                    destCell.Offset(n, 0).Resize(25, 2).Value = Application.Transpose(.Range("B11:B12").Value)
                    destCell.Offset(n, 2).Resize(25, 2).Value = .Range("A18:B42").Value
                    n = n + 25
                Else
                'What would go here?'
                End If
            End With
            dataWb.Close False
        End If
    Next
Click to expand...
 
Upvote 0
John,

Sorry one more question.....the workbooks have multiple worksheet tabs, and it seems that if the Workbook doesn't open on the 'Details' tab, the logic fails to copy over to the Summary sheet. If the Workbook was saved on the Details tab, all seems ok. How can I assure that the Workbook opens to the 'Details' tab?

ddander54 said:
Well that was easy! I just gave it a try as is and it seemed to work fine.....I just let the End If go on to End With and Close the workbook
Click to expand...
 
Upvote 0
Your code change only works when the workbook opens on the 'Details' sheet because you haven't qualified the Ranges with a specific sheet and therefore they default to the active sheet, which sometimes happens to be 'Details'. Fix this by preceding both Ranges with "." (dot operator) so that they reference the 'Details' sheet specified by With dataWb.Worksheets(fromSheetName) regardless of which sheet is active when the workbook opens.

VBA Code: 
              If .Range("C11").Value = "PPM/Proposal #" Then
                    destCell.Offset(n, 0).Resize(25, 2).Value = Application.Transpose(.Range("D11:D12").Value)
                    destCell.Offset(n, 2).Resize(25, 2).Value = .Range("C18:D42").Value
                    n = n + 25
               ElseIf .Range("A11").Value = "PPM/Proposal #" Then
                    destCell.Offset(n, 0).Resize(25, 2).Value = Application.Transpose(.Range("B11:B12").Value)
                    destCell.Offset(n, 2).Resize(25, 2).Value = .Range("A18:B42").Value
                    n = n + 25
                End If

ddander54 said:
what would I use to end the If>Else so it if it doesn't find these 2 conditions, it just closes the workbook and goes on to the next?
Click to expand...
Nothing is needed, not even an Else clause - the code will just fall through to the Close statement.
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Solved
Macro to open multiple workbooks and copy a range of data based on todays date. Then paste the data in master workbook in one sheet under each other.
Replies
8
Views
613
Luke1690
L
C
  • Solved
Copy data from multiple sheets into a master sheet - VBA button stuck
Replies
3
Views
185
NdNoviceHlp
NdNoviceHlp
F
  • Solved
Copy paste from one Excel workbook to another with same sheet names and update dates in range
Replies
8
Views
514
Skiier89
S
S
  • Question Question
Gathering Data From Multiple Files in Same Folder in Particular Range
3 4 5
Replies
41
Views
2K
kvsrinivasamurthy
K
A
  • Question Question
Code for copying data from multiple workbooks
2 3
Replies
24
Views
740
AbhishekJain
A

Forum statistics

Threads
1,223,919
Messages
6,175,371
Members
452,638
Latest member
Oluwabukunmi

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