excelvba

Pull data from multiple workbooks based on a dynamic list

I wrote this rudimentary vba code to pull data from multiple workbooks.

Sub AllocationPull()
Dim wkb1 As Excel.Workbook
Dim wkb2 As Excel.Workbook
Dim wkb3 As Excel.Workbook
Dim wkb4 As Excel.Workbook
Dim wkb5 As Excel.Workbook
Dim wkb6 As Excel.Workbook

Dim wks1 As Excel.Worksheet
Dim wks2 As Excel.Worksheet
Dim wks3 As Excel.Worksheet
Dim wks4 As Excel.Worksheet
Dim wks5 As Excel.Worksheet
Dim wks6 As Excel.Worksheet

Application.ScreenUpdating = False

Set wkb1 = ThisWorkbook
Set wkb2 = Excel.Workbooks.Open(Sheet5.Range("C3").Value)
Set wkb3 = Excel.Workbooks.Open(Sheet5.Range("C4").Value)
Set wkb4 = Excel.Workbooks.Open(Sheet5.Range("C5").Value)
Set wkb5 = Excel.Workbooks.Open(Sheet5.Range("C6").Value)

Set wks1 = wkb1.Worksheets("Backend2")
Set wks2 = wkb2.Worksheets(Sheet5.Range("S3").Value)
Set wks3 = wkb3.Worksheets(Sheet5.Range("S4").Value)
Set wks4 = wkb4.Worksheets(Sheet5.Range("S5").Value)
Set wks5 = wkb5.Worksheets(Sheet5.Range("S6").Value)

With wks2
.Range("A1:B30").Copy Destination:=wks1.Range("A2")
End With
wkb2.Close SaveChanges:=False

With wks3
.Range("A1:B30").Copy Destination:=wks1.Range("C2")
End With
wkb3.Close SaveChanges:=False

With wks4
.Range("A1:B30").Copy Destination:=wks1.Range("E2")
End With
wkb4.Close SaveChanges:=False

With wks5
.Range("A1:B30").Copy Destination:=wks1.Range("G2")
End With
wkb5.Close SaveChanges:=False



Application.ScreenUpdating = True


End Sub

It is opening spreadsheets based on concatenate formulas in sheet 5 range C3:C20 including the file path & the name of the sheet I want to pull data from. This range is Dynamic so more often than not, the majority of the cells are blank--which as you can imagine stops my code from working. Is there a way to alter the code so it loops through range C3:C20 and only pulls data if the cell is not blank? I've done something similar in the past like

Dim lastrow As Long
Dim i As Long, j As Long
Dim wkb As Excel.Workbook

For i = lastrow to 2 Step -1

but it's been years now so I'm not sure how to do these looping codes anymore.

Thanks!

Solution

  • Pull Data From Multiple Workbooks Based On a Dynamic List

    Sub PullAllocations()

    ' Destination
    Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
    Dim dws As Worksheet: Set dws = dwb.Worksheets("Backend2")
    Dim dcell As Range: Set dcell = dws.Range("A2")
    Dim dColumnOffset As Long: dColumnOffset = dws.Range("A1:B30").Columns.Count
    
    ' Lookup
    Dim lws As Worksheet: Set lws = Sheet5 ' also in 'ThisWorkbook' (code name)
    Dim lrg As Range: Set lrg = lws.Range("C3:C20")
    Dim lcell As Range: Set lcell = lrg.Find("*", , xlValues, , , xlPrevious)
    If lcell Is Nothing Then Exit Sub ' no data
    Set lrg = lrg.Resize(lcell.Row - lrg.Row + 1)
        
    Application.ScreenUpdating = False
    
    Dim swb As Workbook, sws As Worksheet, srg As Range
    Dim sFilePath As String, sSheetName As String
    
    For Each lcell In lrg.Cells
        ' Retrieve the file and sheet names.
        sFilePath = CStr(lcell.Value)
        sSheetName = CStr(lcell.EntireRow.Columns("S").Value)
        If Len(sFilePath) > 0 And Len(sSheetName) > 0 Then ' both not blank
            ' Open, copy & close.
            Set swb = Workbooks.Open(sFilePath)
            Set sws = swb.Sheets(sSheetName)
            Set srg = sws.Range("A1:B30")
            srg.Copy Destination:=dcell
            swb.Close SaveChanges:=False
        End If
        ' To copy consecutively (adjacent to each other) no matter
        ' the lookup cell, move this line right above the 'End If' line.
        Set dcell = dcell.Offset(, dColumnOffset) ' next destination cell
    Next lcell
        
    Application.ScreenUpdating = True
    
    MsgBox "Allocations pulled.", vbInformation

End Sub

    Edit