Question

我已经坚持了好几个星期并尝试了很多配方组合但却无法解决这个问题。我不了解VBA，所以不知道从哪里开始。

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

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

见下文。清单3是结果

我把它分成两部分，我尝试使用一个公式，将行复制了匹配的次数。然后我打算复制粘贴或找到一些vba或公式来组合表格，但当我意识到他们的表格没有以相同的顺序排序时，我走到了尽头。我最终将这两个列表结合起来

试过这个VBA 得到此错误

Answer 1

试试这个。

运行宏＆＃34;测试＆＃34;

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

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

OutputSheet应该是您要在

上输出列表的工作表

您还可以选择设置输出行和输出列（如果您没有指定，它将从A1开始）

Sub CreateList(List1 As Range, List2 As Range, OutputSheet As Worksheet, Optional ORow As Long = 1, Optional OCol As Long = 1)
Dim c, d
For Each c In List1
    For Each d In List2
        If c = d Then
            OutputSheet.Cells(ORow, OCol).Value = c.Value
            OutputSheet.Cells(ORow, OCol + 1).Value = c.Offset(0, 1).Value
            OutputSheet.Cells(ORow, OCol + 2).Value = d.Offset(0, 1).Value
            ORow = ORow + 1
        End If
    Next d
Next c
End Sub

Sub Test()
With Sheets("Sheet1")
    CreateList .Range("A2:A7"), .Range("D2:D6"), Sheets("Sheet2")
End With
End Sub

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

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

首先它将检查If 10 = 10 Then - 输出数字，输出第一个列表上数字旁边的文本，然后输出第二个列表中数字旁边的数量。

然后它将行增加1。

这几乎就是它的全部内容 - 只需确保正确指定范围并根据需要更改工作表参考。

如果您之前从未使用过VBA，可以按ALT+F11

打开窗口

右键单击左侧并选择Insert -> Module

将代码粘贴到右侧。

更新以下行的范围，使其与列表所在位置匹配：

CreateList .Range("A2:A7"), .Range("D2:D6"), Sheets("Sheet2")

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

选择“测试”，然后单击“运行”

输入：

结果：

Answer 2

这个怎么样？

下面的代码假设在Sheet1上，数据从Row2开始，其中Row1是标题行。

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

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

2 个答案: