VBA Macro Help - Extract from Multiple Closed Workbooks

Hi there! :hi:

I am so very frustrated and hoping someone can help me! :help

I am trying to compile a quarterly report using specific cell data from 39 separate workbooks titled QR1-01.xlsx through QR1-54.xlsx. All workbooks are in the same folder and I want to extract the same exact cells from each workbook and put into separate rows in one worksheet called Master Summary. Also, I will need to pull data from a specific sheet in each workbook named Quarter1.

The first file in the folder is QR1-01, and I will be exporting specific cells out of it into the Master Summary.xlsx for each site.

Cells to extract from QR1-01.xlsx from sheet titled Quarter1:

sum(D9;D11)
sum(E9:E11)
sum(H9:H11)
K21
K22
K23
K28
K29
K30
I88
J90
G101
E106
C108
F111
F112
F117
F118
C142
E142

I want the data from these cells to populate in order in separate rows on the Master Summary from each file in the designated folder: S:\All_Fiscal\Quarter Reports\FY 15-16\QR-1\Approved

I'm not too worried about headers, I can assign them after the data transfers.

The Master Summary will be in a different location, probably here: S:\All_Fiscal\Quarter Reports\FY 15-16\Summary-Synopsis Documents

The name of the sheet from each workbook (where the data will be extracting) will be Quarter1

Here is the code that I think will work, I'm just not familiar enough with VBA to customize it for me.

Thank you thank you!!! :bow:

Code:

---


Sub CollectDataBits()
 
    Dim fname As String
    Dim fpath As String
    Dim r As Long
    Dim c As Long
    Dim clarray
    Dim datasht As Worksheet
  Dim destsht As Worksheet
    Application.ScreenUpdating = False
 
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
            If .Show Then fpath = .SelectedItems(1) & "\" Else Exit Sub
        End With
 
    clarray = Array("B8", "B9", "B10", "B12", "F8", "G8", "C2")
    r = Range("A" & Rows.Count).End(xlUp).Row
    Set destsht = ActiveSheet
    Application.DisplayAlerts = False
    For r = 2 To r
        fname = fpath & Cells(r, 1)
        Set datasht = Nothing
        On Error Resume Next
        Set datasht = Workbooks.Open(fname, , True).Sheets(1)
        On Error GoTo 0
        If Not datasht Is Nothing Then
            For c = LBound(clarray) To UBound(clarray)
                destsht.Cells(r, c + 3) = datasht.Range(clarray(c))
            Next c
            datasht.Parent.Close
        End If
    Next r
    Application.DisplayAlerts = True
 
End Sub

---