方案一：数据少时省事
Private Sub CustomTransform1()
Dim Wb As Workbook, Sht As Worksheet
Dim NewSht As Worksheet, Dic As Object
Dim EndRow As Long, iRow
Set Dic = CreateObject("Scripting.Dictionary")
Set Wb = Application.ThisWorkbook
Set Sht = Wb.Worksheets("原始数据")
'新建一张工作表，若之前已经存在同名工作表，直接删除
Set NewSht = Wb.Worksheets.Add(After:=Wb.Worksheets(Wb.Worksheets.Count))
Application.DisplayAlerts = False '关闭警告提示
On Error Resume Next
Wb.Worksheets("转置结果").Delete
On Error GoTo 0
Application.DisplayAlerts = True '重新打开警告提示
NewSht.Name = "转置结果"
NewSht.Cells.ClearContents
With Sht
EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
For i = 1 To EndRow
Key = .Cells(i, 1).Value
'当A列的某个信息第一次出现时，为它编排一个序号，同时作为转置后的行号
If Dic.Exists(Key) = False Then
Dic(Key) = Dic.Count + 1
End If
iRow = Dic(Key) '输出的行号
NewSht.Cells(iRow, "A").Value = Key
NewSht.Cells(iRow, "IV").End(xlToLeft).Offset(0, 1).Value = .Cells(i, 2).Value
Next i
End With
'释放对象
Set Dic = Nothing: Set Wb = Nothing
Set Sht = Nothing: Set NewSht = Nothing
End Sub
方案二：数据多时效率相对高点
Private Sub CustomTransform2()
Dim Wb As Workbook, Sht As Worksheet
Dim NewSht As Worksheet, Dic As Object
Dim Arr(), Ar As Variant
Dim EndRow As Long, EndCol As Long
Set Dic = CreateObject("Scripting.Dictionary")
Set Wb = Application.ThisWorkbook
Set Sht = Wb.Worksheets("原始数据")
'新建一张工作表，若之前已经存在同名工作表，直接删除
Set NewSht = Wb.Worksheets.Add(After:=Wb.Worksheets(Wb.Worksheets.Count))
Application.DisplayAlerts = False '关闭警告提示
On Error Resume Next
Wb.Worksheets("转置结果").Delete
On Error GoTo 0
Application.DisplayAlerts = True '重新打开警告提示
NewSht.Name = "转置结果"
NewSht.Cells.ClearContents
With Sht
EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
Set Rng = .Range("A1:B" & EndRow)
Ar = Rng.Value
r = 0
ReDim Arr(1 To EndRow, 1 To 20) '构造二维数组
For i = LBound(Ar) To UBound(Ar)
Key = CStr(Ar(i, 1))
If Dic.Exists(Key) = False Then
Dic(Key) = 1
Else
Dic(Key) = Dic(Key) + 1
End If
r = Dic.Count: c = Dic(Key)
Arr(r, 1) = r: Arr(r, c + 1) = Ar(i, 2)
Next i
End With
'快速输出结果
NewSht.Range("A1").Resize(UBound(Arr), UBound(Arr, 2)).Value = Arr
'释放对象
Set Dic = Nothing: Set Wb = Nothing
Set Sht = Nothing: Set NewSht = Nothing
End Sub