格式化数据：列到行

我有一个大的数据集，包含两列，重复的行名称，但唯一的行值。 这是一个小例子：

A 1 A 2 A 3 A 4 A 5 A 6 A 7 B 8 B 9 B 10 B 11 B 12 B 13 B 14 C 15 C 16 C 17 C 18 C 19 C 20 C 21 

我想将其转换为多列的几行。 喜欢这个：

 A 1 2 3 4 5 6 7 B 8 9 10 11 12 13 14 C 15 16 17 18 19 20 21 

我试图logging一个macros，但我无法弄清楚如何让macros不仅从B1：B7中select单元格的范围，而且还单击B8时从B8：B14中select单元格的范围。 macros总是回复到B1：7。

这是我的例子macros：

 Sub Macro2() Range("B1:B7").Select Selection.Copy Range("D2").Select Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True End Sub 

我做了一些广泛的search，并不能提供一个简单的答案。 我很抱歉，如果这是基本的。

感谢您的帮助。

我应该更具体地了解我的数据。 这里是一个例子，但是每行的名字都有更多的行。

A * 01：01 24575.73
A * 01：01 66.87
A * 01：01 38.21
A * 01：01 24532.88
A * 01：01 2090.44
A * 01：01 61.87
A * 01：01 41.01
A * 02：01 306.68
A * 02：01 24.96
A * 02：01 23182.25
A * 02：01 28.23
A * 02：01 54.94
A * 02：01 39.87
A * 02：01 22734.92
A * 02：03 22.83
A * 02：03 131.63
A * 02：03 35.51
A * 02：03 71.33
A * 02：03 30.82
A * 02：03 24.21
A * 02：03 25.23

Answer 1

尝试像这样的事情：

 Const DEST_COLUMN As Integer = 5 Sub ByMakah() Dim lastRow As Integer, rowIndex As Integer Dim name As String, value As String, destionationRow As Integer, destionationCol As Integer 'Clear Area Range("E:AA").ClearContents lastRow = Range("A10000").End(xlUp).Row Range(Cells(1, 1), Cells(lastRow, 1)).Copy Cells(1, DEST_COLUMN).PasteSpecial Range(Cells(1, DEST_COLUMN), Cells(lastRow, DEST_COLUMN)).RemoveDuplicates Columns:=1, Header:=xlYes 'Fill values For rowIndex = 2 To lastRow name = Cells(rowIndex, 1) value = Cells(rowIndex, 2) destionationRow = WorksheetFunction.Match(name, Columns(DEST_COLUMN), False) 'Get lastCol destionationCol = Cells(destionationRow, 1000).End(xlToLeft).Column + 1 Cells(destionationRow, destionationCol) = value Next rowIndex End Sub 

Answer 2

一个简单的解决办法是：

 Sub transposer() Dim lcell As Range Dim c_row As Integer Dim a_cell As String Dim c_col As Long Sheet1.Columns("A:B").Sort key1:=Sheet1.Range("A2"), order1:=xlAscending, Header:=xlYes For Each lcell In Sheet1.Range("$A$1", "$A$" & Sheet1.Cells(Rows.Count, 1).End(xlUp).Row) If a_cell <> lcell Then c_row = c_row + 1 a_cell = lcell Sheet1.Cells(c_row, 3) = a_cell c_col = 4 End If Sheet1.Cells(c_row, c_col) = Sheet1.Cells(lcell.Row, 2) c_col = c_col + 1 Next lcell Sheet1.Range("A:B").EntireColumn.Delete End Sub 

如果没有标题，则假定有标题

 Sheet1.Columns("A:B").Sort key1:=Sheet1.Range("A2"), order1:=xlAscending, Header:=xlYes 

应该

 Sheet1.Columns("A:B").Sort key1:=Sheet1.Range("A1"), order1:=xlAscending 

Answer 3

此方法使用变体arrays来快速执行转置

它的工作

• 列A和B的X = Range([a1], Cells(Rows.Count, "B").End(xlUp))
• 使用此行转储到C1 [c1].Resize(UBound(X, 1), UBound(X, 1)) = Y

码

 Sub ByeSwanny() Dim X Dim Y Dim lngRow As Long Dim lngCnt1 As Long Dim lngCnt2 As Long X = Range([a1], Cells(Rows.Count, "B").End(xlUp)) ReDim Y(1 To UBound(X, 1), 1 To UBound(X, 1)) Y(1, 1) = X(1, 1) Y(1, 2) = X(1, 2) lngCnt1 = 2 lngCnt2 = 1 For lngRow = 2 To UBound(X, 1) If X(lngRow, 1) = X(lngRow - 1, 1) Then lngCnt1 = lngCnt1 + 1 Y(lngCnt2, lngCnt1) = X(lngRow, 2) Else lngCnt1 = 2 lngCnt2 = lngCnt2 + 1 Y(lngCnt2, 1) = X(lngRow, 1) Y(lngCnt2, 2) = X(lngRow, 2) End If Next lngRow [c1].Resize(UBound(X, 1), UBound(X, 1)) = Y End Sub 

Answer 4

这个解决scheme从这里稍微改编（另请参阅接受的答案 ）。 如果源范围是A1：B21（可以轻松扩展），并且希望将新数据存储在D1：L3中，请使用以下公式：

对于D1： =INDEX($A$1:$A$50,ROW()*7-6,1)

对于E1： =INDEX($B$1:$B$50,ROW()*7-6,1)

对于F1： =INDEX($B$1:$B$50,ROW()*7-5,1)

对于G1： =INDEX($B$1:$B$50,ROW()*7-4,1)

…第1行依此类推。然后根据需要从D1：L1向下复制。

这种方法的好处是它不使用VBA。

缺点是每个字母使用固定数量的项目。 如果这是可变的，我认为更复杂的公式可能会完成这项工作，并有一个明确的方式与VBA做到这一点。