excel - 将列表中的条目复制到 Excel VBA 中的表中

Question

我有一个包含人员姓名、认证姓名和认证到期日期的大型列表。

我正在尝试编写一个脚本来将每个条目的认证到期日期复制到一个表中，该表在一个轴上具有人员姓名，在另一个轴上具有认证名称。

脚本需要根据证书名称和人员姓名识别表中的哪个单元格是每个条目的正确单元格，然后将证书到期日期复制到该单元格中。

我已经一步一步地写出了需要发生的事情，但是对于 VBA 来说是新手，所以很难让它发挥作用。

标签： excelvba

Answer 1

您不需要宏来执行此操作。只需使用数据透视表：

如果你真的需要 VBA 代码（不是很优雅，会提交给 CodeReview 寻求改进建议）：

Sub PivotData()

    Dim rng As Range, cll As Range
    Dim arr As New Collection, a
    Dim var() As Variant
    Dim l As Long
    Dim lRow As Long, lCol As Long

    l = 1

    Set rng = Range("A2:C7")

    ' Create unique list of names
    var = Range("A2:A7")
    On Error Resume Next
    For Each a In var
        arr.Add a, a

    Next
    For l = 1 To arr.Count
        Cells(l + 1, 5) = arr(l)
    Next
    Set arr = Nothing

    ' Create unique list of certificates
    var = Range("B2:B7")
    For Each a In var
        arr.Add a, a
    Next
    For l = 1 To arr.Count
        Cells(1, 5 + l) = arr(l)
    Next
    Set arr = Nothing
    On Error GoTo 0

    Range("F2").FormulaArray = _
        "=IFERROR(INDEX(R2C3:R7C3,MATCH(1,((R2C1:R7C1=RC5)*(R2C2:R7C2=R1C)),0)),"""")"

    With Range("F2")
        lRow = .CurrentRegion.Rows.Count
        lCol = .CurrentRegion.Columns.Count + 4
    End With

    Range("F2:F" & lRow).FillDown
    Range(Cells(2, 6), Cells(lRow, lCol)).FillRight

End Sub