[SOLVED] VBA to do a HLookup across multiple cells like an autofill

VBA to do a HLookup across multiple cells like an autofill

Dim bcell As Range, aRow As Variant
Dim cn As Long: cn = 0

For Each bcell In jdrg.Cells
    With bcell.EntireRow
        If bcell.Value = "" And .Columns("F").Value <> "" Then
            Sh1.Range("L" & vFirstRow + cn, "BD" & vFirstRow + cn).Value = _
             WorksheetFunction.HLookup(Sh1.Range("L$1"), _
                                       Sh2.Range("$A$1:$AE$2"), 2, False)
            Sh1.Range("K" & vFirstRow + cn).Value = "Printed"
            cn = cn + 1
        End If
    End With
Next bcell

I have this code currently however I would like the Range L:BD to have the HLookup work kind of like a autofill with

WorksheetFunction.HLookup(Sh1.Range("L$1"), Sh2.Range("$A$1:$AE$2"), 2, False)

In ("L$1") the L should go up to BD as it goes across. Is there an easy way of making it do this because currently it just does L in all.

After help from CDP1802 below this is my final code and works great

Sub DoMailMerge2()
'Note: A VBA Reference to the Word Object Model is required, via Tools|References
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim strWorkbookName As String: strWorkbookName = ThisWorkbook.FullName
    Dim f As String
    Dim r As Range: Set r = Selection
    Dim nLastRow As Long: nLastRow = r.Rows.Count + r.Row - 2
    Dim nFirstRow As Long: nFirstRow = r.Row - 1
    Dim vFirstRow As Long: vFirstRow = r.Row
    Dim vLastRow As Long: vLastRow = r.Rows.Count + r.Row - 1
    Dim WFile As String: WFile = Range("A2").Value
    Dim sheetname As String: sheetname = ActiveSheet.Name
    Dim Sh1 As Worksheet: Set Sh1 = ActiveSheet
    Dim Sh2 As Worksheet: Set Sh2 = Sheets("Calibrated Gear")
    Dim rng As Range
    Dim jdrg As Range: Set jdrg = Sh1.Range("K" & vFirstRow, "K" & vLastRow)
    
    f = "=IfError(HLookup(R1C,'" & Sh2.Name & "'!R1C1:R2C31,2,False), """")" ' $A$1:$AE$2

    Dim bcell As Range, rr As Long
    For Each bcell In jdrg.Cells
        rr = bcell.Row
        If bcell = "" And Sh1.Cells(rr, "F") <> "" Then
            Sh2.Range("A2").Value = Sh1.Range("F" & rr).Value
            Set rng = Sh1.Range("L1:BD1").Offset(rr - 1)
            rng.Formula2R1C1 = f
            rng.Value = rng.Value
        End If
    Next bcell
    
    Dim found As Boolean: found = False
    
    For Each Cell In Range("L" & vFirstRow, "BD" & vLastRow).Cells
        If Cell.Value = "OUT OF DATE" Then
            found = True
        End If
    Next

    If found = True Then
        MsgBox "One or more calibrated tools are out of date and no replacements in date available."
        Exit Sub
    End If

ActiveWorkbook.Save
With wdApp
  'Disable alerts to prevent an SQL prompt
  .DisplayAlerts = wdAlertsNone
  'Open the mailmerge main document
  Set wdDoc = .Documents.Open("S:\ISO\ISO - Form Templates\All certificates\" & WFile, _
    ConfirmConversions:=False, ReadOnly:=True, AddToRecentfiles:=False)
  With wdDoc
    With .MailMerge
      'Define the mailmerge type
      .MainDocumentType = wdFormLetters
      'Define the output
      .Destination = wdSendToNewDocument
      .SuppressBlankLines = True
      'Connect to the data source
      .OpenDataSource Name:=strWorkbookName, ReadOnly:=False, _
        LinkToSource:=False, AddToRecentfiles:=False, _
        Format:=wdOpenFormatAuto, _
        Connection:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "User ID=Admin;Data Source=" & strWorkbookName & ";" & _
        "Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
        SQLStatement:="SELECT * FROM `" & sheetname & "$`", _
        SubType:=wdMergeSubTypeAccess
      With .DataSource
        .FirstRecord = nFirstRow
        .LastRecord = nLastRow
      End With
      'Excecute the merge
      .Execute
      'Disconnect from the data source
      .MainDocumentType = wdNotAMergeDocument
    End With
    'Close the mailmerge main document
    .Close False
  End With
  'Restore the Word alerts
  .DisplayAlerts = wdAlertsAll
  'Display Word and the document
  .Visible = True
  .Activate
  .Dialogs(wdDialogFilePrint).Show
  wdApp.ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
  wdApp.Quit

End With

            jdrg.Value = "Printed"
End Sub

In the first few columns I manually put in some data and then depending on the date in F I need it to make sure calibrated tools are in date and then automatically change to the next one if first one is not in date (This is all done with some formulas on 'Calibrated Gear' Sheet). If there is no tools of its type in date it stops the word document certificate merge from printing. I have multiple sheets for different products so thats why it is very dynamic.

Thankyou

Solution

Insert the formula as GSerg suggested

Option Explicit

Sub demo()

    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim jdrg As Range, rng As Range, f As String

    ' test values
    Set sh1 = Sheet1
    Set sh2 = Sheet2
    Set jdrg = sh1.Range("B1:B10")
    
    ' HLOOKUP formula
    f = "=HLookup(R1C,'" & sh2.Name & "'!R1C1:R2C31,2,False)" ' $A$1:$AE$2
    
    Dim bcell As Range, r As Long
    For Each bcell In jdrg.Cells
        r = bcell.Row
        If bcell = "" And sh1.Cells(r, "F") <> "" Then
        
            ' HLOOKUP range
            Set rng = sh1.Range("L1:BD1").Offset(r - 1)
            rng.Formula2R1C1 = f
            'rng.Value = rng.Value ' replace formula with values if required
            
            sh1.Cells(r, "K") = "Printed"
        End If
       
    Next bcell
End Sub