Помогите с простым Excel макросом

[_Den_]

У кого есть свободная минута времени, помогит плз с макросом.

есть фаил с одним столбиком и кучей строк.
1
2
1
2
1
2

нужно перенести четные строки во второй столбик, пустые потереть, на выходе получить два столбика

1 2
1 2
1 2
1 2

....

[pashulka]

Помните, как у Остера "А куча - это сколько ?"

а если серьёзно, то при относительно небольшом количестве строк, вполне можно использовать и такой вариант :

Код: Выделить всё

Private Sub Test()
    Dim iMin&, iMax&, iRow&, iDeleteRow As Range
    
    iMin = 1 'самая первая строка с данными
    iMax = Cells(Rows.Count, 1).End(xlUp).Row
    
    Application.ScreenUpdating = False
    
    Set iDeleteRow = Rows(iMin + 1)
    For iRow = iMin To iMax Step 2
        'Application.StatusBar = iRow
        Cells(iRow, 2) = Cells(iRow + 1, 1)
        Set iDeleteRow = Union(iDeleteRow, Rows(iRow + 1))
    Next
    iDeleteRow.Delete
    
    'Application.StatusBar = False
    Application.ScreenUpdating = True
End Sub

[pashulka]

Если же строк действительно много, то в данном конкретном случае, можно обойтись и без удаления строк, и в итоге, всё равно получить ожидаемый результат :

Код: Выделить всё

Private Sub Test2()
    Dim iMax&, iRow&, iArray As Variant
   
    iMax = Cells(Rows.Count, 1).End(xlUp).Row
    iMax = Application.Ceiling(iMax / 2, 1) '.Round(iMax / 2, 0)
   
    ReDim iArray(1 To iMax, 1 To 2)
  
    For iRow = 1 To iMax
        iArray(iRow, 2) = Cells(iRow * 2, 1)
        iArray(iRow, 1) = Cells((iRow - 1) * 2 + 1, 1)
    Next
    
    Range("A:B").ClearContents
    Range("A1:B1").Resize(iMax) = iArray
End Sub

[_Den_]

Сразу проверил 2й код.
Все работает.
Спасибо большое !! выручили!

[_Den_]

еще раз - спасибо )

извиняюсь, но попрошу еще, если будет время,
добавить условие, что если ячейка пустая, то пропустить ее.

например.
1
2
1
2

1
2
1
2

на выходе будет
1 2
1 2
1
2 1
2 1
2

а с условием
1 2
1 2

1 2
1 2

[pashulka]

Берёте первый вариант и непосредственно перед Set iDeleteRow = Rows(iMin + 1) добавляете следующие строки :

Код: Выделить всё

On Error Resume Next
Columns(1).SpecialCells(xlBlanks).Delete