Pulling Specific Data from multiple separate excel files into one Master File

adefonzo23

New Member
Joined
Feb 5, 2025
Messages
12
Office Version
  1. 365
Platform
  1. Windows
I have created a folder with (roughly) 30 copies of the same Weekly Work Plan file for all my sub-contractors for them to update weekly
1738775166366.png


Each Trade Partner file has a "Data" tab and a "Weekly Work Plan" tab, and the Master file has those plus another tab to track Planned Percentage Complete.

I now am trying to create a VBA and/or Macro in my "00_OH-MOB Master WWP" file - in the Weekly Work Plan tab, which would include a "button", so that once a week, I can run that Macro (push that button), and it will pull all of the data entered from my sub-contractors in the Weekly Work Plan tabs of their individual files, into the Master.

I already have the template set up in the Master File, which follows the same column headers as the individual files (the only difference being the cells indicating "Master Weekly Workplan" vs. "Trade Partner Weekly Workplan :

1738777204580.png


1738777328715.png



I've been online watching videos and trying to read through message boards, but nothing I found seemed to address my specific quandry. Can anyone help out with the process that's needed to get this done? Much thanks to anyone who can help out.
 

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce
Copy/paste this macro into a regular module in your "00_OH-MOB Master WWP" file. Change the folder path (in red) to the actual folder path where your sub-contractors files are saved. Add a button on the "Weekly Work Plan" sheet and assign the macro to it. Please note that the macro will delete any existing sub-contractor data in The Master "Weekly Work Plan" sheet before copying new data to it.
Rich (BB code):
Sub CopyWeeklyData()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWB As Workbook, lRow As Long
    Set desWS = ThisWorkbook.Sheets("Weekly Work Plan")
    desWS.UsedRange.Offset(5).ClearContents
    Const strPath As String = "C:\Test\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set srcWB = Workbooks.Open(strPath & strExtension)
        With srcWB
            With .Sheets("Weekly Work Plan")
                lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                .Range("B6:Q" & lRow).Copy desWS.Cells(desWS.Rows.Count, "B").End(xlUp).Offset(1, 0)
            End With
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
@mumps ...appreciate the quick response...I am a novice at all this, so please bear with me and my ignorance.

I copy/pasted the code you show above, changing to folder path accordingly. When I try to run the Macro, I am getting a run-time error:
1738794158861.png


When I click on the "Debug" link, it highlights the 4th line of the code you sent:
1738794220899.png


Again, I'll apologize for my ignorance, but do you have any further advice on this?
 
Upvote 0
Your Master file should contain a sheet named “Weekly Work Plan”. If it doesn’t exist, the error will be generated. That sheet should also contains all the header rows 1 to 5.
 
Upvote 0
Ok...got that fixed (the tab name is slightly different in the Master file). Got another error code now for this line of code:

1738800673842.png


any further help is appreciated.
 
Upvote 0
As I mentioned in my original response, you have to change the folder path in the line of code above the highlighted line to the actual folder path where your files are saved.
 
Upvote 0
Different method, and see if this works...
Select the folder when dialog comes up.
Code:
Sub test()
    Dim wsNames, e, myDir$, fn$, s$(1), x, msg$
    s(0) = Join([transpose("F"&text(row(1:16),"0"))], ", ")
    wsNames = Array("Data", "Weekly Work Plan")
    For Each e In wsNames
        If Not Evaluate("isref('" & e & "'!a1)") Then MsgBox """" & e & """ sheet is not ready", vbCritical: Exit Sub
    Next
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1) & "\"
    End With
    If myDir = "" Then Exit Sub
    s(0) = "Select " & s(0) & ", '|' From `#$B6:R`;"
    s(1) = "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=#;Extended Properties='Excel 12.0;HDR=No';"
    fn = Dir(myDir & "*.xls*")
    Do While fn <> ""
        If myDir & fn <> ThisWorkbook.FullName Then
            For Each e In wsNames
                x = ExecuteExcel4Macro("'" & myDir & "[" & fn & "]" & e & "'!r1c1")
                If Not IsError(x) Then
                    With CreateObject("ADODB.Recordset")
                        .Open Replace(Replace(s(0), "#", e), "|", fn), Replace(s(1), "#", myDir & fn)
                        ThisWorkbook.Sheets(e).Range("b" & Rows.Count).End(xlUp)(2).CopyFromRecordset .DataSource
                    End With
                Else
                    msg = msg & vbLf & """" & e & """ sheet not found in " & fn
                End If
            Next
        End If
        fn = Dir
    Loop
    If Len(msg) Then MsgBox msg
End Sub
 
Upvote 0
@mumps Apologies...foolish mistake on my part...got that fixed.

But I do have one last question...I failed to mention earlier that I do have some formulas in the subcontractor sheets that auto-populate certain columns based on information provided in others (example, once they input any data in the "Task Description" column, it auto-populates the "Trade Partner" column with their company name). The data in those columns are not carrying over to the master sheet, so is there a modification to the code that would simply pull "values" of the cells from each sheet, and would that solve the problem?
 
Upvote 0
Try:
VBA Code:
Sub CopyWeeklyData()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWB As Workbook, lRow As Long
    Set desWS = ThisWorkbook.Sheets("Weekly Work Plan")
    desWS.UsedRange.Offset(5).ClearContents
    Const strPath As String = "C:\Test\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set srcWB = Workbooks.Open(strPath & strExtension)
        With srcWB
            With .Sheets("Weekly Work Plan")
                lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                .Range("B6:Q" & lRow).Copy
                desWS.Cells(desWS.Rows.Count, "B").End(xlUp).Offset(1, 0).PasteSpecial , xlPasteValues
            End With
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub
 
Upvote 0

First, I truly appreciate your patience with this. I am a complete novice with all of this, and I am so grateful for your time trying to help me out.

That said, I used the code above, made the changes to the folder path as well as the Sheet name on This Workbook (as indicated in the code above), and I am getting a new error code:
1738886136291.png


...which then when I go to "Debug" highlights the following:
1738886204739-png.122112


Strangely, every time I try to Run the Macro, it opens up one of the sub-contractor excel files on my desktop (the first one listed alphabetically under my Master sheet in the folder).

I hate to ask again, but do you know what the fix might be for this?

Again, thank you VERY much for your help and patience.
 

Attachments

  • 1738886204739.png
    1738886204739.png
    39.6 KB · Views: 19
Upvote 0

Forum statistics

Threads
1,226,453
Messages
6,191,135
Members
453,642
Latest member
jefals

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