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

Question

我有一个很大的列表，其中包含人员名称，证书名称和证书到期日期。

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

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

我已经逐步写出了需要发生的事情，但是对于VBA来说是新手，所以努力使它起作用。

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