用于索引匹配查找的VBA按列名称返回多列。但列名称不是查找的第一列

Question

我的情况很复杂，我无法在任何论坛中找到答案，因此将其作为新问题发布。

我希望扩展我现有的 vba 脚本，该脚本对我来说运行良好，当搜索值是第一列时，该脚本返回多个值。但是，当搜索值列名称不在第一列中时，不会显示结果。搜索工作表是 ActiveSheet，原始数据来自工作表名称“Data”。我能够创建如下所示的 VBA。我希望基于列标题名称而不是列号进行搜索。到目前为止，我已经创建了这个，如下所示。我已附加数据的 xlsm 文件。请注意，如果删除前 3 行，它会起作用。

  Sub Lookupbyheader()

    Application.ScreenUpdating = False
    Dim x As Integer, y As Integer
    Dim ws As Worksheet
    Dim strFile As String
    Dim TableArray As Range, hRange As Range

      Const m = "MESSAGE", S = "Data"
      If Not Evaluate("ISREF('" & S & "'!A1)") Then
         Sheets.Add(, ActiveSheet).Name = S
         Application.StatusBar = "Add your search list in Sheet 'DATA' column A and 
          Proceed!!":
          Exit Sub
         Application.StatusBar = False
      Else
         Application.StatusBar = False
      End If

   Set wsED = ActiveWorkbook.ActiveSheet
   Set hRange = wsED.Range("1:1")
   Set rED = ActiveWorkbook.Sheets(S)
   Set xRange = rED.Range("A:A")
   Set hdxRange = rED.Range("1:1")
   Set TableArray = rED.UsedRange.Columns

    empid = WorksheetFunction.Match("EMP ID", hRange, 0)
    ColPI = WorksheetFunction.Match("Port ID", hRange, 0)
    ColDes = WorksheetFunction.Match("Designation", hRange, 0)
    ColN = WorksheetFunction.Match("Name", hRange, 0)
    ColLoc = WorksheetFunction.Match("Location", hRange, 0)

     LastRow = wsED.Cells(Rows.Count, 1).End(xlUp).Row
     LastCol = wsED.Cells(1, Columns.Count).End(xlToLeft).Column

       For x = 2 To LastRow
       For y = 2 To LastCol

      On Error Resume Next
      wsED.Cells(x, y) = WorksheetFunction.Index(TableArray, _
      WorksheetFunction.Match(wsED.Cells(x, empid), xRange, 0), _
      WorksheetFunction.Match(wsED.Cells(empid, y), hdxRange, 0))

      Next y
         Next x
      
         Application.ScreenUpdating = True
     End Sub

PS：我不介意您是否建议一个更快的 vba 脚本，它可以运行得更快并节省时间，因为我正在运行超过 10 k 行的搜索。我当前的脚本大约需要 8-10 秒来运行大量数据。

感谢您在这方面的专业知识。

Answer 1

我从您的请求与所写内容中得出的结论是，您想要找到标题名称并选择其列（

.find()' & '.column

）。

还值得注意的是

on error resume next

的使用，它忽略了最有可能解决的错误 (

if not foundValue is nothing then

)。

我会提出以下模型脚本来帮助简化查找，并且不需要工作表功能：

with sheets(1)
    dim outputRange as range:  set outputRange = .rows(1).find("OutputHeaderName")
    if not outputRange is nothing then
       dim outputColumn as long:  outputColumn = outputRange.column
       dim lastRow as long:  .cells(.rows.count,outputColumn).end(xlup).com
       dim headerArray as variant:  headerArray = ("Header1", "Header2") 
       dim i as long:  for i = lbound(headerArray) to ubound(headerArray)
           if not headerArray(i) is nothing then
               'do something
           end if
       next i
    end if
end with