PDA

View Full Version : VBA Macro Help - Extract from Multiple Closed Workbooks



karma0823
05-10-2016, 01:16 PM
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:




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