Question

我用谷歌搜索了这个问题，但没有任何理由没有弹出，我现在也没有任何线索，如何做到这一点。所以，决定写在这里。

我有大桌子，aprox。 300'000行，在正常行之间，我有一些信息，需要转换成行。作为示例，此信息如下所示：

如果有任何想法突然出现，请告诉我。最好的问候。

Answer 1

300,000行需要一些时间来处理，但这可能会很快完成。

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

处理变体存储器阵列可能会实现更快的处理，但这应该可以完成工作。

Answer 2

我喜欢Jeeped解决方案，但它似乎重新排序可能不需要的数据。这是我提出的解决方案，我没有基准测试，所以我无法判断它是否真的更慢。

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

我想出了混合Jeeped和我的另一个版本：

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

Answer 3

有了这么多的数据，我觉得这个过程会像Jeeped所说的那样在VBA数组中而不是在工作表上完成。这是一个宏。为了告诉从哪里开始新行，我查看了第2列 - 如果第2列为空，则数据将附加到上一行;如果没有，那么就会开始新的一行。

其他类型的测试可以替代。

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

Answer 4

您可以将PasteSpecial功能与Transpose:=True一起使用。例如：

Range("A2:A5").Select
Selection.Copy
Range("E1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

会将A2:A5转置为E2：

Answer 5

首先定义哪些行必须转置！是否只有第一行填充了值？或者值是数字？结果是新的还是相同的工作表？

您可以使用从第一行到最后一行的for循环：

找出插入转置范围的单元格。然后检查哪些范围必须转置。对要转置的第一行和最后一行使用长变量。当带有值的新行出现时，请剪切范围并将其粘贴到所需的单元格中

U可以使用宏录制器来查看如何移调范围。或者看看其他答案。

如果删除行，最好从下到上创建一个新的工作表或循环

VBA将数据行转换为列

5 个答案: