Hello,
Could someone please offer some guidance in the VBA code Ihave pasted below, Im definitely an amateur user who needs alot of help but ivemanaged to cobble together some code by joining other peoples solutionstogether. The VBA i have used works fine but I cannot figure out how to patchin the code that will 'close' the source spreadsheets. What I mean by this isthe VBA code opens all my source spreadsheets and retrieves the data but I haveto manually close the workbooks them when I am finished running the routine.
Background on the task -
I have just under 9000 excel sheets that I need to retrievedata from so that it can be placed into a summary sheet.
The data is located on the third tab inside of my sheetswhich is titled 'report form'
There are multiple cells on this page that I need to retrievethe data from. The data needs to be copied to both new rows and columns.
Source sample spreadsheet, the yellow cells highlights thedata that I need copied out
Destination sample spreadsheet
As you can see I need some of the cells to appear in new rows and others in new columns
If there are any tweaks or improvements to the code please suggest but mostly I need help to have the code close the source spreadsheets once the data has been retrieved.
Thanks in advance
Could someone please offer some guidance in the VBA code Ihave pasted below, Im definitely an amateur user who needs alot of help but ivemanaged to cobble together some code by joining other peoples solutionstogether. The VBA i have used works fine but I cannot figure out how to patchin the code that will 'close' the source spreadsheets. What I mean by this isthe VBA code opens all my source spreadsheets and retrieves the data but I haveto manually close the workbooks them when I am finished running the routine.
Background on the task -
I have just under 9000 excel sheets that I need to retrievedata from so that it can be placed into a summary sheet.
The data is located on the third tab inside of my sheetswhich is titled 'report form'
There are multiple cells on this page that I need to retrievethe data from. The data needs to be copied to both new rows and columns.
Source sample spreadsheet, the yellow cells highlights thedata that I need copied out
Destination sample spreadsheet
As you can see I need some of the cells to appear in new rows and others in new columns
If there are any tweaks or improvements to the code please suggest but mostly I need help to have the code close the source spreadsheets once the data has been retrieved.
Code:
Sub ExtractCells()
' local wb vars
Dim wb As Workbook
Dim ws As Worksheet
Dim MySheet As String
Dim r1 As Range
Dim r2 As Range
Dim r3 As Range
Dim i As Integer
' opened wb vars
Dim OpenWorkbook As Workbook
Dim OpenWorksheet As Worksheet
Dim SheetName As String
' looping params
Dim Directory As String
Dim FileSpec As String
Dim MyFile As String
' define looping params
Directory = "D:\tests\" 'CHANGE THIS
FileSpec = ".xlsx" 'CHANGE THIS IF NECESSARY
MyFile = Dir(Directory & "*" & FileSpec)
SheetName = "report form" 'CHANGE THIS
' set local vars
Set wb = ThisWorkbook
MySheet = "Sheet1" 'CHANGE THIS
Set ws = wb.Worksheets(MySheet)
' This is where data will begin to write
Set r1 = ws.Range("A1")
Set r2 = ws.Range("B1")
Set r3 = ws.Range("C1")
Set r4 = ws.Range("D1")
Set r5 = ws.Range("E1")
Set r6 = ws.Range("F1")
Set r7 = ws.Range("G1")
Set r8 = ws.Range("H1")
Set r9 = ws.Range("I1")
Set r10 = ws.Range("A2")
Set r11 = ws.Range("B2")
Set r12 = ws.Range("C2")
Set r13 = ws.Range("D2")
Set r14 = ws.Range("E2")
Set r15 = ws.Range("F2")
Set r16 = ws.Range("G2")
Set r17 = ws.Range("H2")
Set r18 = ws.Range("I2")
Set r19 = ws.Range("A3")
Set r20 = ws.Range("B3")
Set r21 = ws.Range("C3")
Set r22 = ws.Range("D3")
Set r23 = ws.Range("E3")
Set r24 = ws.Range("F3")
Set r25 = ws.Range("G3")
Set r26 = ws.Range("H3")
Set r27 = ws.Range("I3")
Set r28 = ws.Range("A4")
Set r29 = ws.Range("B4")
Set r30 = ws.Range("C4")
Set r31 = ws.Range("D4")
Set r32 = ws.Range("E4")
Set r33 = ws.Range("F4")
Set r34 = ws.Range("G4")
Set r35 = ws.Range("H4")
Set r36 = ws.Range("I4")
Set r37 = ws.Range("A5")
Set r38 = ws.Range("B5")
Set r39 = ws.Range("C5")
Set r40 = ws.Range("D5")
Set r41 = ws.Range("E5")
Set r42 = ws.Range("F5")
Set r43 = ws.Range("G5")
Set r44 = ws.Range("H5")
Set r45 = ws.Range("I5")
Set r46 = ws.Range("A6")
Set r47 = ws.Range("B6")
Set r48 = ws.Range("C6")
Set r49 = ws.Range("D6")
Set r50 = ws.Range("E6")
Set r51 = ws.Range("F6")
Set r52 = ws.Range("G6")
Set r53 = ws.Range("H6")
Set r54 = ws.Range("I6")
i = 0
' If there is one thing you take away from this, it should be the construct below i.e. how to loop through files
Do While MyFile <> ""
Set OpenWorkbook = Application.Workbooks.Open(Filename:=Directory & MyFile, ReadOnly:=True)
Set OpenWorksheet = OpenWorkbook.Worksheets(SheetName)
' write data down col
With OpenWorksheet
r1.Offset(i, 0).Value = .Range("D11").Value
r2.Offset(i, 0).Value = .Range("D13").Value
r3.Offset(i, 0).Value = .Range("D14").Value
r4.Offset(i, 0).Value = .Range("D15").Value
r5.Offset(i, 0).Value = .Range("D8").Value
r6.Offset(i, 0).Value = .Range("H8").Value
r7.Offset(i, 0).Value = .Range("H7").Value
r8.Offset(i, 0).Value = .Range("H6").Value
r9.Offset(i, 0).Value = .Range("D12").Value
r10.Offset(i, 0).Value = .Range("E11").Value
r11.Offset(i, 0).Value = .Range("E13").Value
r12.Offset(i, 0).Value = .Range("E14").Value
r13.Offset(i, 0).Value = .Range("D15").Value
r14.Offset(i, 0).Value = .Range("D8").Value
r15.Offset(i, 0).Value = .Range("H8").Value
r16.Offset(i, 0).Value = .Range("H7").Value
r17.Offset(i, 0).Value = .Range("H6").Value
r18.Offset(i, 0).Value = .Range("D12").Value
r19.Offset(i, 0).Value = .Range("F11").Value
r20.Offset(i, 0).Value = .Range("F13").Value
r21.Offset(i, 0).Value = .Range("F14").Value
r22.Offset(i, 0).Value = .Range("D15").Value
r23.Offset(i, 0).Value = .Range("D8").Value
r24.Offset(i, 0).Value = .Range("H8").Value
r25.Offset(i, 0).Value = .Range("H7").Value
r26.Offset(i, 0).Value = .Range("H6").Value
r27.Offset(i, 0).Value = .Range("D12").Value
r28.Offset(i, 0).Value = .Range("G11").Value
r29.Offset(i, 0).Value = .Range("G13").Value
r30.Offset(i, 0).Value = .Range("G14").Value
r31.Offset(i, 0).Value = .Range("D15").Value
r32.Offset(i, 0).Value = .Range("D8").Value
r33.Offset(i, 0).Value = .Range("H8").Value
r34.Offset(i, 0).Value = .Range("H7").Value
r35.Offset(i, 0).Value = .Range("H6").Value
r36.Offset(i, 0).Value = .Range("D12").Value
r37.Offset(i, 0).Value = .Range("H11").Value
r38.Offset(i, 0).Value = .Range("H13").Value
r39.Offset(i, 0).Value = .Range("H14").Value
r40.Offset(i, 0).Value = .Range("D15").Value
r41.Offset(i, 0).Value = .Range("D8").Value
r42.Offset(i, 0).Value = .Range("H8").Value
r43.Offset(i, 0).Value = .Range("H7").Value
r44.Offset(i, 0).Value = .Range("H6").Value
r45.Offset(i, 0).Value = .Range("D12").Value
r46.Offset(i, 0).Value = .Range("I11").Value
r47.Offset(i, 0).Value = .Range("I13").Value
r48.Offset(i, 0).Value = .Range("I14").Value
r49.Offset(i, 0).Value = .Range("D15").Value
r50.Offset(i, 0).Value = .Range("D8").Value
r51.Offset(i, 0).Value = .Range("H8").Value
r52.Offset(i, 0).Value = .Range("H7").Value
r53.Offset(i, 0).Value = .Range("H6").Value
r54.Offset(i, 0).Value = .Range("D12").Value
End With
i = i + 6
MyFile = Dir
Loop
End Sub
Thanks in advance
Last edited by a moderator: