Help with retrieving data from multiple workbooks - VBA for an amateur

R

RIGBY

New Member
Joined
Aug 22, 2019
Messages
2
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.

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:

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
Sort by date Sort by votes
Just add this line as shown
Code: 
        End With
        [COLOR=#ff0000]OpenWorkbook.Close False[/COLOR]
        i = i + 6
        MyFile = Dir
    Loop


End Sub
 
Upvote 0
Hi,
untested but see if this update to your code does what you want

Code: 
Sub ExtractCells()
    
    Dim MySheet As String, SheetName As String
' looping params
    Dim Directory As String, FileSpec As String, MyFile As String
    Dim rng As Range, cell As Range
    Dim r As Integer, c As Integer, i As Integer
    Dim arr() As Variant
    
' opened wb vars
    Dim OpenWorkbook As Workbook, wb As Workbook
    Dim OpenWorksheet As Worksheet
    
    
'***************************************************************************************************************
'**************************************************SETTINGS*****************************************************
    Directory = "D:\tests\"
    FileSpec = ".xlsx"
    MyFile = Dir(Directory & "*" & FileSpec)
    
    SheetName = "report form"
    MySheet = "Sheet2"
    
'***************************************************************************************************************
    
' set local vars
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets(MySheet)


'row index counter
    i = 1
    Application.ScreenUpdating = False
    
    Do While MyFile <> ""
        
        Set OpenWorkbook = Application.Workbooks.Open(Filename:=Directory & MyFile, ReadOnly:=True)
        Set OpenWorksheet = OpenWorkbook.Worksheets(SheetName)
        
' write data down col
        Set rng = OpenWorksheet.Range("D11,D13,D14,D15,D8,H6:H8,D12," & _
                                        "E11,E13,E14,D15,D8,H6:H8,D12," & _
                                        "F11,F13,F14,D15,D8,H6:H8,D12," & _
                                        "G11,G13,G14,D15,D8,H6:H8,D12," & _
                                        "H11,H13,H14,D15,D8,H6:H8,D12," & _
                                        "I11,I13,I14,D15,D8,H6:H8,D12")
'size array
        ReDim arr(1 To 6, 1 To 9)


        r = 0
        For Each cell In rng.Cells
            c = c + 1
            If c > 9 Then c = 1
            If c = 1 Then r = r + 1
'populate array elements
            arr(r, c) = cell.Value
        Next cell
        
 'post array to worksheet
        wb.Worksheets(MySheet).Cells(i, 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
'close file
        OpenWorkbook.Close False
        
'clear object variables
        Set OpenWorkbook = Nothing
        Set OpenWorksheet = Nothing
        Set rng = Nothing
'next file
        MyFile = Dir
'next row
        i = i + 6
        Loop
        
        Application.ScreenUpdating = True
End Sub

I have only glanced at what your code is doing but hopefully, update will deliver same result.

Dave
 
Last edited:
Upvote 0
Gents,

Thank you both for your help.
Fluff - your close routine definitely worked for me which I appreciate
DMT32 - Your code worked exactly as I hoped but seems to run alot smoother than the version that I cobbled together. Ie mine lags and the screen seems to flash quite alot while your version runs smoothly.
thank you both for your help with solving this
 
Upvote 0
RIGBY said:
Gents,

thank you both for your help with solving this
Click to expand...

Most welcome - glad we both were able to assist you. many thanks for feedback, it is always appreciated


Dave
 
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Solved
Splitting Data into Workbooks - EDIT HELP
Replies
1
Views
252
horrellbt01
H
J
  • Solved
EXCEL VBA - help to copy filtered data from one workbook to multiple new workbooks and save code.
Replies
2
Views
424
Jordan2
J
C
  • Solved
Copy data from multiple sheets into a master sheet - VBA button stuck
Replies
3
Views
182
NdNoviceHlp
NdNoviceHlp
A
  • Solved
VBA Help!
Replies
2
Views
406
AusNewb
A
N
  • Question Question
Count - specific consecutive order
Replies
6
Views
1K
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,223,889
Messages
6,175,224
Members
452,620
Latest member
dsubash

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top