实现了二维表格转换为一维表格，反过来的功能偶尔也是会用到的：
首先在customUI.xml中增加代码：
代码语言：javascript复制 <button id="rbbtnTarnsTable1To2" label="一维表转二维表" onAction="rbbtnTarnsTable1To2" supertip="将选择的多行3列表格转换为多行多列表格。"/>回调函数：
代码语言：javascript复制Sub rbbtnTarnsTable1To2(control As IRibbonControl)
Call MShtWk.TarnsTable1To2
End Sub函数实现：
代码语言：javascript复制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
