Help with retrieving data from multiple workbooks - VBA for an amateur
Results 1 to 5 of 5

Thread: Help with retrieving data from multiple workbooks - VBA for an amateur
Thanks Thanks: 0 Likes Likes: 0

  1. #1
    New Member
    Join Date
    Aug 2019
    Posts
    2
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    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 Fluff; Aug 22nd, 2019 at 06:36 AM.

  2. #2
    MrExcel MVP
    Moderator
    Fluff's Avatar
    Join Date
    Jun 2014
    Location
    Chippenham
    Posts
    26,976
    Post Thanks / Like
    Mentioned
    460 Post(s)
    Tagged
    45 Thread(s)

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

    Just add this line as shown
    Code:
            End With
            OpenWorkbook.Close False
            i = i + 6
            MyFile = Dir
        Loop
    
    
    End Sub
    - Posting Data try one of these tools
    - Posting guidelines, forum rules and terms of use
    - Read the FAQs

    Running Office 365 on Win 10

  3. #3
    Board Regular
    Join Date
    Jul 2012
    Location
    Hampshire, UK
    Posts
    4,991
    Post Thanks / Like
    Mentioned
    23 Post(s)
    Tagged
    1 Thread(s)

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

    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 by dmt32; Aug 22nd, 2019 at 07:15 AM.

  4. #4
    New Member
    Join Date
    Aug 2019
    Posts
    2
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    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

  5. #5
    Board Regular
    Join Date
    Jul 2012
    Location
    Hampshire, UK
    Posts
    4,991
    Post Thanks / Like
    Mentioned
    23 Post(s)
    Tagged
    1 Thread(s)

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

    Quote Originally Posted by RIGBY View Post
    Gents,

    thank you both for your help with solving this
    Most welcome - glad we both were able to assist you. many thanks for feedback, it is always appreciated


    Dave

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •