Question

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

我想将此转换为包含多列的几行。像这样：

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

我试着录制一个宏，但我无法弄清楚如何让宏不仅从B1：B7中选择单元格的范围，而且当我点击B8时也从B8：B14中选择。宏总是恢复为B1：7。

这是我的示例宏：

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

我做了一些广泛的谷歌搜索，无法想出一个简单的答案。如果这是初步的，我道歉。

感谢您的帮助。

我应该更具体地了解数据的外观。这是一个示例，但每行名称还有更多行。

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

此方法使用变量数组快速执行转置

适用于

此行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

enter image description here

Answer 4

此问题的解决方案略微改编自here（另请参阅this accepted answer）。如果您的源范围是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来实现。

格式化数据：列到行

4 个答案: