将基于一列中的值的Excel工作簿重新组织为多列

Question

我有以下要重组的Excel表格：

我想重新组织表B中所有“类型”的表，它们都有自己的列。 A列中的所有“站点”仅具有唯一值，并且C列中的所有“区域”值填充其与站点和类型相关的位置。请参阅下面所需的输出示例：

这些只是更大数据集的示例，但任务是相同的。我对VBA很熟悉，并且想知道是否有人遇到过类似的问题，哪些功能或程序可以帮助我重组我的桌子？

Answer 1

这假设输入在 Sheet1 上，输出将放在 Sheet2

上

Sub MAIN()
    Dim r1 As Range, r2 As Range, r3 As Range, r4 As Range
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim N As Long, i As Long, j As Long, k As Long
    Dim v1 As Variant, v2 As Variant, v3 As Variant
    Dim r As Range

    Set sh1 = Sheets("Sheet1")
    Set sh2 = Sheets("Sheet2")
    N = sh1.Cells(Rows.Count, "A").End(xlUp).Row
    Set r1 = sh1.Range("A2:A" & N)
    Set r2 = sh1.Range("B2:B" & N)
    Set r3 = sh2.Range("A2:A" & Rows.Count)
    Set r4 = sh2.Range(sh2.Cells(1, 2), sh2.Cells(1, Columns.Count))
    Call ExtractUniques(r1, r3)
    Call ExtractUniques(r2, r4)

    For i = 2 To N
        v1 = sh1.Cells(i, 1).Value
        v2 = sh1.Cells(i, 2).Value
        v3 = sh1.Cells(i, 3).Value
        j = 2
        k = 2

        For Each r In r3
            If v1 = r.Value Then
                Exit For
            Else
            j = j + 1
            End If
        Next r
        For Each r In r4
            If v2 = r.Value Then
                Exit For
            End If
            k = k + 1
        Next r
        sh2.Cells(j, k).Value = v3
    Next i
End Sub

Sub ExtractUniques(rIn As Range, rOut As Range)
    Dim C As Collection, r As Range
    Set C = New Collection
    Dim cC As Long
    On Error Resume Next
    For Each r In rIn
        If r.Value <> "" Then
            C.Add r.Value, CStr(r.Value)
        End If
    Next r
    cC = C.Count
    i = 1
    For Each r In rOut
        r.Value = C.Item(i)
        i = i + 1
        If i > cC Then Exit Sub
    Next r
End Sub