常用功能加载宏——一维表转二维表

      <button id="rbbtnTarnsTable1To2" label="一维表转二维表" onAction="rbbtnTarnsTable1To2" supertip="将选择的多行3列表格转换为多行多列表格。"/>

Sub rbbtnTarnsTable1To2(control As IRibbonControl)
    Call MShtWk.TarnsTable1To2
End Sub

Sub TarnsTable1To2()
    Dim drow As Object
    Dim dcol As Object

    Set drow = VBA.CreateObject("Scripting.Dictionary")
    Set dcol = VBA.CreateObject("Scripting.Dictionary")

    Dim i As Long
    Dim arr() As Variant
    Dim rng As Range

    '确保选中的是单元格
    If TypeName(Selection) <> "Range" Then
        Exit Sub
    End If
    Set rng = Selection
    If rng.Columns.Count <> 3 Then
        MsgBox "只能处理3列数据，其中第3列必须是数字。"
        Exit Sub
    End If
    If rng.rows.Count < 2 Then
        MsgBox "数据至少要有2行。"
        Exit Sub
    End If
    arr = rng.Value
    
    Dim rngout As Range
    On Error Resume Next
    Set rngout = Application.InputBox("请选择输出的起始单元格。", Default:=rng.Range("A1").Offset(rng.rows.Count + 1, 0).Address, Type:=8)
    On Error GoTo 0
    If rngout Is Nothing Then Exit Sub
    Set rngout = rngout.Range("A1")
    
    '记录项目的行号、姓名的列号
    Dim strkey As String
    For i = 2 To UBound(arr)
        strkey = VBA.CStr(arr(i, 1))
        If Not drow.Exists(strkey) Then drow(strkey) = drow.Count + 1
        
        strkey = VBA.CStr(arr(i, 2))
        If Not dcol.Exists(strkey) Then dcol(strkey) = dcol.Count + 1
    Next
    
    Dim Result() As Variant
    ReDim Result(1 To drow.Count + 1, 1 To dcol.Count + 1) As Variant
    Result(1, 1) = "项目"
    
    Dim tmp
    tmp = drow.keys()
    '行
    For i = 0 To drow.Count - 1
        Result(i + 2, 1) = tmp(i)
    Next
    
    tmp = dcol.keys()
    '列
    For i = 0 To dcol.Count - 1
        Result(1, i + 2) = tmp(i)
    Next
    
    Dim pRow As Long, pcol As Long
    '数据
    For i = 2 To UBound(arr)
        pRow = drow(VBA.CStr(arr(i, 1))) + 1
        pcol = dcol(VBA.CStr(arr(i, 2))) + 1
        
        Result(pRow, pcol) = Result(pRow, pcol) + VBA.Val(arr(i, 3))
    Next
    rngout.Resize(drow.Count + 1, dcol.Count + 1).Value = Result
    
    Set drow = Nothing
    Set dcol = Nothing
End Sub