如果数据是新的数据组/ excel vba，则仅将数据转置到新列

Question

我在excel中有一列数据，可能有超过2000行的数据。在该数据中，每次找到新组时，我都希望将数据组发送到新列的顶部。我已经查看了转置的特殊粘贴选项以及使用分隔符，但我只能将数据移到一列而不是顶部。我正在寻找一种快速的解决方案，因为需要将数据量分成新列。我很感激帮助。

下面是数据的外观表。

以下是我希望数据显示的方式

Answer 1

试试这个简单的代码，

Sub splitRange()
Dim i As Long, j As Long, k As Long
Cells(1, 6) = Cells(1, 1)
Cells(1, 7) = Cells(1, 2)
j = 1
k = 6
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    If Cells(i, 1) = Cells(i - 1, 1) Then
        j = j + 1
        Cells(j, k) = Cells(i, 1)
        Cells(j, k + 1) = Cells(i, 2)
    Else
        k = k + 3
        j = 1
        Cells(j, k) = Cells(i, 1)
        Cells(j, k + 1) = Cells(i, 2)
    End If
Next i
End Sub

如果要在单独的工作表中输出输出，请修改代码。我希望你谷歌它来了解它。

Answer 2

我必须做类似的事情。您也可以尝试以下代码：

Sub Move_Data()

    Application.ScreenUpdating = False

    Dim r  As Integer
    Dim StartRow As Integer
    Dim EndRow As Integer
    Dim ColA As Integer
    Dim vLastRow As Integer
    Dim vEnd As Integer

    r = 1
    StartRow = 1
    EndRow = 1
    ColA = 4
    vEnd = 1

    vLastRow = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row

    Do Until Cells(r, 1) <> Cells(StartRow, 1)
        DoEvents
        r = r + 1
    Loop

    vEnd = r

    Do Until r > vLastRow

        DoEvents

        StartRow = r

        Do Until Cells(r, 1) <> Cells(StartRow, 1)
            DoEvents
            r = r + 1
        Loop

        EndRow = r - 1

        Range(Cells(StartRow, 1), Cells(EndRow, 2)).Select

        Selection.Copy

        Cells(1, ColA).Select

        ActiveSheet.Paste

        ColA = ColA + 3

    Loop

    r = vEnd + 1

    Range(Cells(vEnd, 1), Cells(vLastRow, 2)).ClearContents

    Cells(1, 1).Select

    Application.ScreenUpdating = True

    MsgBox "Done"

End Sub