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

我在Excel中有一列数据可能有超过2000行的数据。 在这些数据中，每当发现一个新的组时，都会将数据组发送到新列的顶部。 我已经看到转置的特殊粘贴选项与使用分隔符，但我只能移动数据一列而不是顶部。 我正在寻找一个快速的解决scheme，因为需要将数据拆分成新的列。 我感谢帮助。

以下是数据如何显示的表格。

以下是我希望看到的数据

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