Macro to Open Multiple Workbooks from Cell Range & Copy Values from Specific Cells

[whitfoaj]

Good afternoon all,

My current project involves a log report for purchase orders for my employer. Purchase orders are separated by project and are all saved with in their respective project files. A Purchase Order workbook might be titled, "ABC 123 - Sheeting", while another for the same job would be "ABC 140 - Roofing". All are saved in this format, with the job symbol (in this case, ABC) and a number assigned to the PO.

I have created a list in my workbook that will pull the names of all files in the Purchase Order folder for the job. From here, I've separated them out through formulas to list only Purchase Order files.

I managed to get a macro (listed below) to pull the necessary information from the Purchase Orders into a list on another worksheet, but currently the only way to do it is to have it clear the existing list of information and re-pull from every PO each time it has to be run (so, each time a new PO is added). This is fine for small projects that have 7-10 Purchase Orders, but larger ones can contain 80-100, and this simply isn't plausible to do every time.

I used CountIf to create list of the filepaths of only the POs that have not been listed yet on the other page, but I do not know how to program a macro to read from this list and open each file that appears there, then copy information from three cells.

For reference, this is what is being pulled:

Cell J6 on the "Purchase Order" Worksheet in each PO is being placed in Column A in the list (Worksheet called "Test Page" currently)
Cell B10 on the "Purchase Order" Worksheet in each PO is being placed in Column B in the list (same worksheet)
Cell J8 on the "Purchase Order" Worksheet in each PO is being placed in Column C in the list (same)

The list of filepaths that I want to pull from are in the Workbook called "Project Setup Workbook" on the "Purchase Order Log" Worksheet, Column AF (will be either a filepath or blank). These paths are the complete filepaths and do not need to be altered in any way.

This is my existing code:

Option Explicit

Sub Update_PO_List()
     
Application.DisplayAlerts = False
Application.ScreenUpdating = False


Worksheets("Test Page").Activate

Worksheets("Test Page").Range("A1", Columns("A").SpecialCells(xlCellTypeLastCell)).Clear
Worksheets("Test Page").Range("B1", Columns("B").SpecialCells(xlCellTypeLastCell)).Clear
Worksheets("Test Page").Range("C1", Columns("C").SpecialCells(xlCellTypeLastCell)).Clear

   
    Dim matchFiles As String, projectFolder As String, fileName As String
    Dim destinationCell As Range
    Dim rowOffset As Long
    Dim projectWorkbook As Workbook
     
     'Folder and Project workbooks to be copied from
     
    matchFiles = Worksheets("Calculation Page").Range("W15").Value & "*.xlsx" 'CHANGE FOLDER PATH HERE
     
     'Set destination cell to which the first Project workbook value will be copied.
     'This is the first empty cell in Sheet1 column A or A2 if column A is empty
     
    With ActiveWorkbook.Worksheets("Test Page")
        Set destinationCell = .Cells(Rows.Count, "A").End(xlUp).Offset(1)
        rowOffset = 0
    End With
     
    projectFolder = Left(matchFiles, InStrRev(matchFiles, "\"))
    fileName = Dir(matchFiles)
    While fileName <> ""
        Set projectWorkbook = Workbooks.Open(projectFolder & fileName)
         
         'Copy values from Tab 1 C5, Tab 5 A3, Tab 5 A6 to A, B and C cells on next row in Master workbook Sheet1
         
        With destinationCell
            .Offset(rowOffset, 0).Value = projectWorkbook.Worksheets("Purchase Order").Range("J6").Value
            .Offset(rowOffset, 1).Value = projectWorkbook.Worksheets("Purchase Order").Range("B10").Value
            .Offset(rowOffset, 2).Value = projectWorkbook.Worksheets("Purchase Order").Range("J8").Value
        End With
        projectWorkbook.Close False
         
        fileName = Dir()
        rowOffset = rowOffset + 1
    Wend
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
     
End Sub

I'm sure that this code is messy and probably not the most efficient way to go about it, but I'm kind of learning as I go. Any help that anyone can provide is very much appreciated.

Also, if there is anything that I left out that would be useful or if anything could be clarified, please let me know!

Thanks very much!

 

[whitfoaj]

Bumps for help.