Excel VBA循环遍历用空格隔开的文本部分，然后复制并转置到新工作表上

Question

I will like code that can cycle through a worksheet and copy and transpose each section onto another worksheet.

I have code that uses SpecialCells but have had issues with it. I would prefer code that uses Shift+Down then Shift+Right .End(xlDown) .End(xlToRight) .

Here is the code that worked but I had issues when there were blanks in any of the cells. This code copies each area, only need column B and column C then pastes it into worksheet CombinedAndTransposed

    Sub Copy_Transpose_All_Sections()
    Dim Ra As Range

    Application.ScreenUpdating = False
    'B:C 2nd And 3rd Columns to copy
    For Each Ra In Columns("B:C").SpecialCells(xlCellTypeConstants, 23).Areas '23
        Ra.Copy
        Worksheets("CombinedAndTransposed").Cells(Rows.count, "B").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
    Next Ra
    Application.CutCopyMode = False
End Sub 

The data is in the 2nd and 3rd column and is separated with blank rows.

The result should take each section of text and transpose it.

My code above works only when there is data in all cells within a section, but fails if any are missing or any formatting of the cells change.

Answer 1

This is much more efficient.

Private Sub Answer ()
    With Worksheets("Sheet1")
        Dim source As Range
        Set source = .Range("B1", .Range("C" & Rows.Count).End(xlUp))
    End With

    With Worksheets("Sheet2")
        Dim destination As Range
        Set destination = .Range("B1")
    End With

    ' Loop every odd row in range.
    Dim row As Long
    For row = 1 To source.Rows.Count Step 2
        ' Must resize destination range to match source. Transpose data from row to column.
        destination.Resize(source.Rows(row).Cells.Count).Value = Application.Transpose(source.Rows(row))
        ' Set destination to offset with a gap between data.
        Set destination = destination.Offset(destination.Cells.Count + 2)
    Next row
End Sub