Customizing VBA Code - Extract from Multiple Workbooks

[karma0823]

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 rows in one worksheet called Master Summary. Also, I will need to pull data from a specific sheet in each workbook named Quarter1.

I've uploaded two documents. One is the QR1-01, and I will be exporting specific cells out of it into the Master Summary for each site.

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

sum(D15:D17)
sum(E15:E17)
sum(H15:H17)
K27
K28
K29
K34
K35
K36
I94
J96/97
G107
E112
C114
F117
F118
F123
F124
C148
E148

I want the data from these cells to populate in order in a row 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.

1.  Sub x()

2. 

3.  Dim nCount AsLong, wbResults As Workbook, rPaste As Range, wsTo As Worksheet, wsFrom As Worksheet, sFolder AsString

4. 

5.  With Application.FileDialog(msoFileDialogFolderPicker)

6.  .Show

7.  On Error Goto errline

8.  sFolder = .SelectedItems(1)

9.  End With

10.

11.Set wsTo = ThisWorkbook.Sheets("US")

12.wsTo.Activate

13.Set rPaste = Application.InputBox("Enter starting cell to paste", Type:=8)

14.If rPaste IsNothingOr rPaste.Count > 1 Then Exit Sub

15.

16.With Application

17..ScreenUpdating = False: .DisplayAlerts = False: .EnableEvents = False

18.End With

19.On Error Resume Next

20.

21.With Application.FileSearch

22..NewSearch

23..LookIn = sFolder

24..FileType = msoFileTypeExcelWorkbooks

25.If .Execute > 0 Then

26.For nCount = 1 To .FoundFiles.Count

27.Set wbResults = Workbooks.Open(Filename:=.FoundFiles(nCount), UpdateLinks:=0)

28.For Each wsFrom In wbResults.Worksheets

29.With wsTo.Range(rPaste.Address)

30..Value = wsFrom.Range("B5").Value

31..Offset(, 1).Value = wsFrom.Range("B6").Value

32..Offset(, 2).Value = wsFrom.Name

33..Offset(1, 3).Resize(11).Value = wsFrom.Range("B10:B20").Value

34.End With

35.Set rPaste = rPaste.Offset(13)

36.Next wsFrom

37.wbResults.Close SaveChanges:=True

38.Next nCount

39.EndIf

40.End With

41.

42.On Error Goto 0

43.With Application

44..ScreenUpdating = False: .DisplayAlerts = True: .EnableEvents = True

45.End With

46.

47.errline:

Can someone please assist?

 

[karma0823]

Just found another code in another thread that might work too? I really appreciate the help! Thank you!!!

Option Explicit

Sub MoveData()
Dim sPath As String
Dim sFil As String
Dim owb As Workbook
Dim ws As Worksheet
     
    sPath = Sheet1.[a2] 'Points to the path    Set ws = Sheet2 'The Master Data Sheet    sFil = Dir(sPath & "*.xl*") 'Flexible enough to handle all XL file types   Do While sFil <> "" 'Only Copies Cols A to C, starting In A2.        Set owb = Workbooks.Open(sPath & sFil)
      Sheets(1).Range("A2", Range("C" & Rows.Count).End(xlUp)).Copy ws.Range("A" & Rows.Count).End(xlUp)(2)
        owb.Close False 'Close no save        sFil = Dir
    Loop
End Sub