Страница 1 из 1
Помогите с простым Excel макросом
Добавлено: 23 май 2013, 12:52
_Den_
У кого есть свободная минута времени, помогит плз с макросом.
есть фаил с одним столбиком и кучей строк.
1
2
1
2
1
2
нужно перенести четные строки во второй столбик, пустые потереть, на выходе получить два столбика
1 2
1 2
1 2
1 2
....
Re: Помогите с простым Excel макросом
Добавлено: 23 май 2013, 19:44
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
Re: Помогите с простым Excel макросом
Добавлено: 23 май 2013, 20:51
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
Re: Помогите с простым Excel макросом
Добавлено: 24 май 2013, 09:50
_Den_
Сразу проверил 2й код.
Все работает.
Спасибо большое !! выручили!
Re: Помогите с простым Excel макросом
Добавлено: 24 май 2013, 12:52
_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
Re: Помогите с простым Excel макросом
Добавлено: 24 май 2013, 17:47
pashulka
Берёте первый вариант и непосредственно
перед Set iDeleteRow = Rows(iMin + 1) добавляете следующие строки :
Код: Выделить всё
On Error Resume Next
Columns(1).SpecialCells(xlBlanks).Delete