问VBA将数据行转换为列。

EN

Option Explicit
Sub TransposeSomeRows()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes() As Variant
    Dim I As Long, J As Long, K As Long

    Dim lRowCount As Long, lColCount As Long

Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
    Set rRes = wsRes.Cells(1, 1)

With wsSrc.Cells
    lRowCount = .Find(what:="*", after:=.Item(1, 1), LookIn:=xlValues, _
        searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    lColCount = .Find(what:="*", after:=.Item(1, 1), _
        searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
End With

'Read source data into array
With wsSrc
    vSrc = .Range(.Cells(2, 1), .Cells(lRowCount, lColCount))
End With

'create results array
'Num of rows = number of items in Column 2
lRowCount = WorksheetFunction.CountA(wsSrc.Columns(2))

'Num of columns = max of entries in a "start row" plus blanks to next "start row"
lColCount = 0
For I = 1 To UBound(vSrc, 1)
    If vSrc(I, 2) <> "" Then
        For J = 1 To UBound(vSrc, 2)
            If vSrc(I, J) <> "" Then K = J
        Next J
    Else 'vSrc(i,2) = "" so add a column
        K = K + 1
    End If

    lColCount = IIf(lColCount > K, lColCount, K)

Next I


ReDim vRes(1 To lRowCount, 1 To lColCount)

'Populate results array
K = 0
For I = 1 To UBound(vSrc, 1)
    If vSrc(I, 2) <> "" Then
        K = K + 1
        J = 1
        For J = 1 To UBound(vSrc, 2)
            If vSrc(I, J) <> "" Then
                vRes(K, J) = vSrc(I, J)
            Else
                Exit For
            End If
        Next J
    Else
        vRes(K, J) = vSrc(I, 1)
        J = J + 1
    End If
Next I

'Write results to worksheet
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    .EntireColumn.AutoFit
End With

End Sub

Sub duplicate()
    Dim rw As Long, nrw As Long

    Application.ScreenUpdating = False

    With Worksheets("Sheet1")   '<~~ set this worksheet properly!
        For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
            If Not IsNumeric(.Cells(rw, 1).Value2) Then
                nrw = Application.Match(1E+99, .Cells(1, 1).Resize(rw - 1, 1))
                .Cells(nrw, Columns.Count).End(xlToLeft).Offset(0, 1) = .Cells(rw, 1).Value2
                .Rows(rw).Delete
            Else
                With .Rows(rw)
                    .Cells.Sort Key1:=.Cells(1), Order1:=xlAscending, _
                        Orientation:=xlLeftToRight, Header:=xlNo
                End With
            End If
        Next rw
    End With

    Application.ScreenUpdating = True

End Sub

Public Sub Test()
    Dim lastRow As Long, firstRow As Long, lastCell As Range, rng As Range
    Dim currentRow As Long
    Application.ScreenUpdating = False
    lastRow = Cells(Rows.Count, 1).End(xlUp).Row
    For currentRow = lastRow To 1 Step -1
        If IsNumeric(Cells(currentRow, 1).Value) Then
            Set lastCell = Cells(currentRow, 1).End(xlToRight).Offset(0, 1)

            Set rng = Range(Cells(firstRow, 1), Cells(lastRow, 1))
            rng.Copy
            lastCell.PasteSpecial Transpose:=True
            rng.EntireRow.Delete
            lastRow = currentRow - 1
        Else
            firstRow = currentRow
        End If
    Next currentRow
    Application.ScreenUpdating = False
End Sub

Public Sub Test2(Optional ws As Worksheet)
    Dim lastRow As Long, lastCell As Range, rng As Range
    Dim currentRow As Long

    Application.ScreenUpdating = False

    If ws Is Nothing Then Set ws = ActiveSheet

    Dim BigestValue As Variant
    BigestValue = ws.Evaluate([MAX(A:A)])
    lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    For currentRow = lastRow To 1 Step -1
        If Not IsNumeric(ws.Cells(currentRow, 1).Value) Then
            'look up for last numeric cell
            lastRow = currentRow
            currentRow = Application.Match(BigestValue, ws.Cells(1, 1).Resize(currentRow, 1))
            Set lastCell = ws.Cells(currentRow, 1).End(xlToRight).Offset(0, 1)
            Set rng = Range(ws.Cells(currentRow + 1, 1), ws.Cells(lastRow, 1))
            rng.Copy
            lastCell.PasteSpecial Transpose:=True
            rng.EntireRow.Delete
        End If
    Next currentRow

    Application.ScreenUpdating = True
End Sub