如何让VBA中HLookup实现类似自动填充的跨列匹配效果

问题描述 #

原始VBA代码中，HLookup始终以Sh1.Range("L$1")作为查找值，导致L到BD列的结果均为L列表头的匹配值，无法实现每列对应自身上方表头（从L1到BD1）进行HLookup匹配的效果。

原始代码 #

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

问题分析 #

原始代码的核心问题在于：HLookup的查找值被固定为L$1单元格，无论填充到哪一列，都只会用L1的值去匹配，无法像Excel自动填充那样，让每列使用自身顶部的表头作为查找值。

优化后完整代码 #

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

功能说明 #

优化后的代码实现以下功能：

• 手动输入部分数据后，根据F列日期校验「Calibrated Gear」工作表中的校准工具是否过期，过期则自动替换为有效工具；
• 若检测到无可供替换的有效工具，将弹出提示并终止Word邮件合并打印流程；
• 适配多产品工作表的动态需求，支持基于选中区域进行批量处理。

内容的提问来源于stack exchange，提问作者Todd Harris