Транспонировать строки в столбцы на нерегулярных и противоречивых данных

Question

Я должен транспонировать строки в столбцы в Excel, используя VBA, и данные около 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

Я отредактировал ваш код, чтобы показать подход, который может работать на вас. Вам необходимо добавить условие для данных одной ячейки.

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

Answer 2

Тогда это должно быть сделано, помните, что я предполагаю, где ваши данные и куда они будут вставлены, не забудьте изменить это:

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