Вырезать / скопировать / вставить альтернативные строки ячейки в следующий столбец и удалить пустые строки после

Question

У меня проблемы с выделением / копированием альтернативных строк в одном столбце, вставкой его в следующий столбец и выравниванием.

Вот скриншот:

Answer 1

Вы можете взять этот код и настроить его по вкусу:

Sub alternate()
    Dim i As Integer
    Dim j As Integer
    Dim n As Integer

    i = 0
    j = 0
    n = 0

    With ActiveSheet        
        For Each c In .Range("A4:A16")
            .Cells(20 + j, 1 + i).Value = c.Value
            If n = 0 Or n Mod 2 = 0 Then
                i = 1
                j = j
            Else
                i = 0
                j = j + 1
            End If
            n = n + 1
        Next c
    End With    
End Sub

Это сработало для меня при восстановлении вашего примера с буквами (для более быстрой проверки).

Answer 2

В следующем коде предполагается, что у вас есть две отдельные вкладки, SRC и DST, а диапазон данных начинается в первой ячейке. Сделаем все за один шаг:

Public Sub CopyAlternate()
Dim i As Long

i = 2

While Len(Sheets("SRC").Cells(i, 1).Value) > 0
    Sheets("DST").Cells(i / 2 + 1, 1).Value = Sheets("SRC").Cells(i, 1).Value
    Sheets("DST").Cells(i / 2 + 1, 2).Value = Sheets("SRC").Cells(i + 1, 1).Value
    i = i + 2
Wend
End Sub