Loop Vlookup to LastRow of Column A, but vlookup starts in a different cell each day

Question

I'm a newbie to VBA and this is my first post. I've searched but can't seem to find anything that matches my scenario without using set ranges.

I have a worksheet that holds a list of account numbers in column A (no blank cells in between) and dates across the top row. Each day the user downloads a balances report from the bank and imports it in to this macro.

I want the macro to vlookup the accounts that are in column A of my list (sheetname is Balances) and return the balances for each account from the imported list (sheetname is Todays Bals - Account is Col B and Balance is Col C).

I'm trying to get a vlookup to work from the next empty cell in the top data row (row 2) to the bottom of the account list but it's going past the last non-empty cell and overwriting totals (with #N/A) that are at the bottom of the sheet, formulated ready for when the vlookup is completed for that day. (The totals have a blank row in between the list of accounts).

I think I may have contradicted the lastrow and activecell in the code, but I don't know how to fix it.

Any help is appreciated.

Below is my code so far:

Sub Vlookup()

Dim LastRow As Long

Worksheets("Balances").Activate

    If Range("C2").Value > 0 Then             '1st day of balances start in C2
        Range("C2").End(xlToRight).Offset(0, 1).Select
    Else
        Range("C2").Select
    End If

    If Sheets("Todays Bals").Range("A2") <> Sheets("Balances").Cells(1, ActiveCell.Column) Then
        MsgBox "These balances are for a different day.  Please import the correct day"
    Exit Sub
    Else
    
'Above is fine
'Below is where the issue is 

    LastRow = Range("A" & Rows.Count).End(xlUp).Row
           
    Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 0).End(xlDown)).Offset(0, 0).Formula = _
    "= vlookup(A2,'Todays Bals'!B:C,2,FALSE)"
    
    End If

End Sub

Answer 1

A Multi VBA Lookup (Application.Match)

• To not further complicate matters (e.g. by using the Find method), I have used the strange condition that cell A3 in the destination can't be empty to ensure the success of xlDown. It is assumed that there is an empty row between the accounts and the totals row.
• Also, I haven't used arrays or a dictionary to keep it simple (hmm!?).

Sub CopyAccountBalances()
    
    ' Define constants.
    
    Const SRC_SHEET As String = "Todays Bals"
    Const SRC_DATE_CELL As String = "A2"
    Const SRC_FIRST_ACCOUNTS_CELL As String = "B5" ' ?
    Const SRC_BALANCES_COLUMN As String = "C"
    
    Const DST_SHEET As String = "Balances"
    Const DST_DATE_FIRST_CELL As String = "C1"
    Const DST_FIRST_ACCOUNTS_CELL As String = "A2"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET)
    
    Dim sDate: sDate = sws.Range(SRC_DATE_CELL).Value
    
    If Not IsDate(sDate) Then
        MsgBox "The source date cell contains the invalid """ _
            & CStr(sDate) & """.", vbCritical
        Exit Sub
    End If
    
    Dim sarg As Range, srCount As Long
    
    With sws.Range(SRC_FIRST_ACCOUNTS_CELL)
        srCount = sws.Cells(sws.Rows.Count, .Column).End(xlUp).Row - .Row + 1
        If srCount < 1 Then
            MsgBox "No accounts in worksheet """ & SRC_SHEET & """.", vbCritical
            Exit Sub
        End If
        Set sarg = .Resize(srCount)
    End With
    
    Dim sbrg As Range: Set sbrg = sarg.EntireRow.Columns(SRC_BALANCES_COLUMN)
    
    ' Destination
    
    Dim dws As Worksheet: Set dws = wb.Sheets(DST_SHEET)
    
    Dim ddrg As Range, dcCount As Long
    With dws.Range(DST_DATE_FIRST_CELL)
        dcCount = dws.Cells(.Row, sws.Columns.Count).End(xlToLeft).Column _
            - .Column + 1
        If dcCount < 1 Then
            MsgBox "No dates in worksheet """ & DST_SHEET & """.", vbCritical
            Exit Sub
        End If
        Set ddrg = .Resize(, dcCount)
    End With
    
    Dim dDateColumnIndex:
    dDateColumnIndex = Application.Match(CLng(sDate), ddrg, 0)
    
    If IsError(dDateColumnIndex) Then
        MsgBox "The date """ & CStr(sDate) _
            & """ was not found in worksheet """ & DST_SHEET & """.", _
            vbCritical
        Exit Sub
    End If
    
    Dim darg As Range, drCount As Long
    
    With dws.Range(DST_FIRST_ACCOUNTS_CELL)
        With .Offset(1)
            If IsEmpty(.Value) Then
                MsgBox "The second accounts cell """ & .Address(0, 0) _
                    & """ can't be empty.", vbCritical
                Exit Sub
            End If
        End With
        drCount = .End(xlDown).Row - .Row + 1
        Set darg = .Resize(drCount)
    End With
    
    Dim dbrg As Range: Set dbrg = darg.EntireRow _
        .Columns(ddrg.Cells(dDateColumnIndex).Column)
    
    ' The Lookup
    
    Dim dCell As Range, dValue, srIndex, dr As Long
    
    For Each dCell In darg.Cells
        dr = dr + 1
        dValue = dCell.Value
        If Len(CStr(dValue)) > 0 Then ' is not blank
            srIndex = Application.Match(dValue, sarg, 0)
            If IsNumeric(srIndex) Then ' match found in source range row
                dbrg.Cells(dr).Value = sbrg.Cells(srIndex).Value
            End If
        End If
    Next dCell
        
    ' Inform.
        
    MsgBox "Account balances copied.", vbInformation

End Sub