Question

我必须使用vba在excel中将行转置为列，数据大约为500000。

问题在于数据不规则且一致。就像将有4行然后是空白，然后可以是三行或一行一样。我想将由空白单元格分隔的一组数据转置到第一个条目前面的相应列。

Sub Transpose()
    ' Transpose Macro
    ' Keyboard Shortcut: Ctrl+Shift+T
    Do Until IsEmpty(ActiveCell.Value)
        Range(Selection, Selection.End(xlDown)).Select

        Application.CutCopyMode = False

        Selection.Copy

        ActiveCell.Offset(0, 1).Range("A1").Select
        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=   _
          False, Transpose:=True

        ActiveCell.Offset(0, -1).Range("A1").Select

        Selection.End(xlDown).Select
        Selection.End(xlDown).Select
    Loop
End Sub

我使用了这段代码，但是问题是它跳过了单行中存在的数据。

Answer 1

然后应该这样做，请注意，我假设您的数据在哪里以及将要粘贴到哪里，请不要忘记更改它：

Option Explicit
Sub Transpose()

    Dim LastRow As Long 'last row on the sheet
    Dim TransposeRow As Long 'row where we transpose
    Dim x As Long 'columns
    Dim C As Range 'faster looping through cells with For Each C in range

    With ThisWorkbook.Sheets("MySheet") 'change this to your sheet
        'To assign the last row im gonna assume your data is in column A or 1(B would be 2 and so...)
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'Last row with data
        TransposeRow = .Cells(.Rows.Count, 2).End(xlUp).Row + 1 'on column B will be pasting the data
        x = 2 'initialize x being 2 as for B column
        For Each C In .Range("A2:A" & LastRow)
            If C = vbNullString Then 'in case the cell is blank we jump a row
                TransposeRow = .Cells(.Rows.Count, 2).End(xlUp).Row + 1 ' recalculate row for transposing data
                x = 2 'reinitialize column counter
            Else
                .Cells(TransposeRow, x) = C 'we copy the value to the row and column empty
                x = x + 1 'add 1 column
            End If
        Next C
    End With

End Sub

Answer 2

我已经编辑了您的代码，以显示适合您的方法。您需要为一个单元格数据添加条件。

Sub Transpose2()
' Transpose Macro
' Keyboard Shortcut: Ctrl+Shift+T
Do Until IsEmpty(ActiveCell.Value)
    If IsEmpty(ActiveCell.Offset(1, 0).Value) Then
        Selection.Copy
        ActiveCell.Offset(0, 1).Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        ActiveCell.Offset(0, -1).Range("A1").Select
    Else
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        ActiveCell.Offset(0, 1).Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        ActiveCell.Offset(0, -1).Range("A1").Select
        Selection.End(xlDown).Select
    End If
    Application.CutCopyMode = False
    Selection.End(xlDown).Select
 Loop
End Sub

注意：通常不建议使用select。减少select的示例是：

Sub Transpose3()
' Transpose Macro
' Keyboard Shortcut: Ctrl+Shift+T
Do Until IsEmpty(ActiveCell.Value)
    If IsEmpty(ActiveCell.Offset(1, 0).Value) Then
        ActiveCell.Copy ActiveCell.Offset(0, 1)
    Else
        Range(ActiveCell, ActiveCell.End(xlDown)).Copy
        ActiveCell.Offset(0, 1).Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        ActiveCell.Offset(0, -1).Range("A1").End(xlDown).Select
    End If
    Application.CutCopyMode = False
    Selection.End(xlDown).Select
 Loop
End Sub

在不规则和不一致的数据上将行转置为列

2 个答案: