Macro to automatically pull cells from thousands of workbooks into one master workbook


New Member
Feb 4, 2019

I have been a long time lurker but first time making an account and posting.

I am tasked with taking a folder with many (up to thousands) of single sheet workbooks and getting about 5-7 nonconsecutive cells and moving them into a master workbook. (I specifically want cells A10, A11, A6, A55, A56 in that order) to populate across one row in the master workbook, and then eventually take cells A55 and A56 and run a macro to see if values are within a certain threshold of one another.

There are some caveats which I think are making this more difficult for me:
1. The files are not excel files but "cal files" which are text files... If they need to be excel files I will need to find a way to change all of them
2. Each workbook in the folder has a different name and a single sheet with a single column (which I would like to add a macro to separate these by an = sign before they get transferred to the master workbook)
3. I believe these folders will be getting new files regularly, so it would be nice to have some sort of update button that will not duplicate or delete other files.

This is a lot, but any help would be insanely appreciated!

Here is some code I have tried and been playing with:

Sub RefreshMasterList()

    Const SRC_FOLDER As String = "Z:\"
    Const COL_FNAME As Long = 1
    Const COL_LAST_MOD As Long = 2

    Dim fso As New Scripting.FileSystemObject
    Dim fold As Scripting.Folder, fl As Scripting.File
    Dim f As Range, sht As Worksheet, rw As Range, dtlm
    Dim getInfo As Boolean, wb As Workbook, ws As Worksheet
    Dim baseName As String

    Set sht = ThisWorkbook.Sheets("Master")

    'clear all file status flag colors
    sht.Columns(COL_FNAME).Interior.ColorIndex = xlNone

    Set fold = fso.GetFolder(SRC_FOLDER)
    For Each fl In fold.Files
        If fl.Name Like "*.xls*" Then
            getInfo = False
            dtlm = Format(fl.DateLastModified, "yyyy-mm-dd-hh:mm:ss")
            baseName = fso.GetBaseName(fl.Name)

            'have this file already ?
            Set f = sht.Columns(1).Find(baseName, lookat:=xlWhole, _
            If f Is Nothing Then 'not already listed...
                Set rw = sht.Cells(Rows.Count, COL_FNAME).End(xlUp) _
                                    .Offset(1, 0).EntireRow
                With rw
                    .Cells(COL_FNAME).Value = baseName
                    'flag new
                    .Cells(COL_FNAME).Interior.Color = vbGreen
                    .Cells(COL_LAST_MOD).Value = dtlm
                End With
                getInfo = True
                Set rw = f.EntireRow
                If rw.Cells(COL_LAST_MOD).Value < dtlm Then
                    Debug.Print f.Cells(COL_LAST_MOD).Value, dtlm
                    'flag updated
                    rw.Cells(COL_FNAME).Interior.Color = vbYellow
                    rw.Cells(COL_LAST_MOD).Value = dtlm
                    getInfo = True
                    'flag no change
                    rw.Cells(COL_FNAME).Interior.Color = RGB(220, 220, 220)
                End If
            End If

            If getInfo Then 'need to add/update from this file?
                Set wb = Workbooks.Open(fl.Path, , True)
                With wb.Sheets("Purchase Order")
                    rw.Cells(3).Value = .Range("A10").Value
                    rw.Cells(4).Value = .Range("A11").Value
                End With
                wb.Close False 'don't save...
            End If

        End If
    Next fl
End Sub

as well as

Sub ConsolidateWbks()

    Dim Pth As String
    Dim MstSht As Worksheet
    Dim fname As String
    Dim Rng As Range
Application.ScreenUpdating = False

    Pth = "L:\Stormwater\Data\EXO Calibration Files\Calibration Files\0003"
    Set MstSht = ThisWorkbook.Sheets("Sheet1")
    fname = Dir(Pth & "*xls*")
    Do While Len(fname) > 0
        Workbooks.Open (Pth & fname)
        With Workbooks(fname)
            Set Rng = MstSht.Range("E" & Rows.Count).End(xlUp).Offset(1)
            Rng.Resize(, 34).Value = Application.Transpose(.Sheets("Global FACT").Range("B2:B35").Value)
            Rng.Offset(, 35).Value = .Sheets("Global FACT").Range("C36").Value
            Rng.Offset(, 36).Value = .Sheets("CRF").Range("C12").Value
            Rng.Offset(, 37).Value = .Sheets("CRF").Range("C16").Value
            Rng.Offset(, 38).Value = .Sheets("CRF").Range("G4").Value
            Application.DisplayAlerts = False
            .Close , False
            Application.DisplayAlerts = True
        End With
        fname = Dir

End Sub

The above code was taken from other websites and I have attempted to make it work with my needs, but to no avail.

Thanks again!

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
not sure how to do this, but make sure you pull the file name when you get the data otherwise you won't know where it came from
Upvote 0

Forum statistics

Latest member

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
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 "".
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