Excel 在新表中查找并返回多个匹配项

我已经坚持了好几个星期，尝试了很多配方奶粉，但都没能奏效。我不知道VBA，所以不知道从哪里开始

我有下面的清单1和清单2。我需要从列表1和2中的数据创建列表3。清单3最好可以在新的表格中创建

我需要从列表2中的A列（D列）中查找条件，然后返回一个新列表中的所有匹配项，该列表显示：列表1；标准（A列），B列数据；和列表2中的所有匹配项（E列）

见下文。清单3是结果

我将其分为两部分，并尝试使用一个公式来复制行的匹配次数。然后我打算复制粘贴或找到一些vba或公式来组合表格，但当我意识到这些表格的排序顺序不一样时，我陷入了死胡同。最后，我将这两个列表合并起来

试过这个VBA 获取此错误

试试这个

运行宏“测试”

第一个参数应该是第一个列表的范围（只是数字）

第二个参数应该是第二个列表的范围（只是数字）

OutputSheet应该是要在其上输出列表的工作表

您还可以选择设置输出行和输出列（如果未指定，它将从

A1

开始）

代码循环遍历第一个列表中的每个数字，然后遍历第二个列表中的每个数字

如果数字相同，则输出数字、项目和价格

首先，如果10=10，它将检查

，然后

-输出数字，在第一个列表的数字旁边输出文本，并在第二个列表的数字旁边输出金额

然后将行增加1

这就是它的全部内容——只要确保正确指定范围并根据需要更改图纸引用即可

如果以前从未使用过VBA，则可以按ALT+F11打开窗口

右键单击左侧并选择

Insert->Module

将代码粘贴到右侧

更新下一行中的范围，使其与列表的位置相匹配：

CreateList.Range（“A2:A7”）、.Range（“D2:D6”）、表单（“Sheet2”）

然后，您可以关闭窗口并按ALT+F8打开运行宏对话框

选择测试并单击运行

输入：

结果:

这个怎么样

下面的代码假定在Sheet1上，数据从第2行开始，其中第1行是标题行

Sub CreateList()
Dim x, y, z()
Dim i As Long, j As Long, k As Long, n As Long, dlr As Long
Dim wsData As Worksheet, wsOutput As Worksheet
Application.ScreenUpdating = False
Set wsData = Sheets("Sheet1")
On Error Resume Next
Set wsOutput = Sheets("List")
wsOutput.Cells.Clear
On Error GoTo 0
If wsOutput Is Nothing Then
    Sheets.Add(after:=wsData).Name = "List"
    Set wsOutput = ActiveSheet
End If
x = wsData.Range("A1").CurrentRegion.Value
y = wsData.Range("D1").CurrentRegion.Value

For i = 2 To UBound(x, 1)
    If Application.CountIf(wsData.Columns("D"), x(i, 1)) > 0 Then
        n = Application.CountIf(wsData.Columns("D"), x(i, 1))
        ReDim z(1 To n)
        k = 1
        For j = 2 To UBound(y, 1)
            If y(j, 1) = x(i, 1) Then
                z(k) = y(j, 2)
                k = k + 1
            End If
        Next j
        dlr = wsOutput.Range("C" & Rows.Count).End(3)(2).Row
        wsOutput.Range("A" & dlr).Value = x(i, 1)
        wsOutput.Range("B" & dlr).Value = x(i, 2)
        wsOutput.Range("C" & dlr).End(3)(2).Resize(UBound(z, 1), 1) = Application.Transpose(z)
    End If
    Erase z
Next i
dlr = wsOutput.Range("C" & Rows.Count).End(3)(2).Row
If dlr > 1 Then
    wsOutput.Range("A2:C" & dlr).CurrentRegion.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
    wsOutput.Rows(1).Delete
End If
Application.ScreenUpdating = True
End Sub

---

您介意VBA解决方案吗？我不是索引/匹配公式的粉丝，尽管我想你会这么做。是的，我需要一个VBA。我只是不知道自己怎么写。如果你需要我的回答，请告诉我。我相信你会得到这方面的帮助，因为你只有一张纸。它试图把它放在

sheet 2

上，而你只有

sheet 1

你的解决方案有效！非常感谢。不知道它是怎么从这里消失的。。。。我最后运行了它，在同一个工作簿中被分成6张Sperate表。好的。我在一个新的工作簿中重新开始，这次没有错误消息…对你有用吗？从您的屏幕截图判断，您似乎不小心将部分代码粘贴到了一个单独的模块中，您将实际代码放入了

Sheet5

中，而不是一个模块，我在一个新工作簿中重新开始，只使用了一页数据，但现在我收到了一条不同的消息。我将把mscreenshot放在帖子上（不知道如何在注释中执行）好的，当你放入代码时，请密切注意

test

宏中的行<代码>带图纸（“Sheet1”）创建列表。范围（“A2:A7”），.Range（“D2:D6”）。图纸（“Sheet2”）以结尾，意思是“我的数据在<代码>图纸1-第一个列表是<代码>范围（“A2:A7”）-第二个列表是<代码>范围（“D2:D6”）-我希望您将其放在

工作表2

哦，是的，我忘了在新工作簿中打开第二张工作表。请重试

Sub CreateList()
Dim x, y, z()
Dim i As Long, j As Long, k As Long, n As Long, dlr As Long
Dim wsData As Worksheet, wsOutput As Worksheet
Application.ScreenUpdating = False
Set wsData = Sheets("Sheet1")
On Error Resume Next
Set wsOutput = Sheets("List")
wsOutput.Cells.Clear
On Error GoTo 0
If wsOutput Is Nothing Then
    Sheets.Add(after:=wsData).Name = "List"
    Set wsOutput = ActiveSheet
End If
x = wsData.Range("A1").CurrentRegion.Value
y = wsData.Range("D1").CurrentRegion.Value

For i = 2 To UBound(x, 1)
    If Application.CountIf(wsData.Columns("D"), x(i, 1)) > 0 Then
        n = Application.CountIf(wsData.Columns("D"), x(i, 1))
        ReDim z(1 To n)
        k = 1
        For j = 2 To UBound(y, 1)
            If y(j, 1) = x(i, 1) Then
                z(k) = y(j, 2)
                k = k + 1
            End If
        Next j
        dlr = wsOutput.Range("C" & Rows.Count).End(3)(2).Row
        wsOutput.Range("A" & dlr).Value = x(i, 1)
        wsOutput.Range("B" & dlr).Value = x(i, 2)
        wsOutput.Range("C" & dlr).End(3)(2).Resize(UBound(z, 1), 1) = Application.Transpose(z)
    End If
    Erase z
Next i
dlr = wsOutput.Range("C" & Rows.Count).End(3)(2).Row
If dlr > 1 Then
    wsOutput.Range("A2:C" & dlr).CurrentRegion.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
    wsOutput.Rows(1).Delete
End If
Application.ScreenUpdating = True
End Sub