数据格式转置

方案一：数据少时省事

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