Всем привет ещё раз. Задача удалять по две строки через интервал (условно говоря через две строки) при этом в одном из столбцов (первом) дублировать значение. Можно в несколько шагов
пример 1 22 33 23 34
2 42 54 47 52
РЕзультат 1 22 33 1 23 34 2 42 54 2 47 52
Всем привет ещё раз. Задача удалять по две строки через интервал (условно говоря через две строки) при этом в одном из столбцов (первом) дублировать значение. Можно в несколько шагов
Макрос сделан под файл-пример. Предполагается, что шапки у таблицы нет (т.е. данные начинаются сразу со строки 1).
[vba]
Код
Sub Дублировать_и_Удалить_пустые()
Dim arr(), lr As Long, i As Long
Application.ScreenUpdating = False lr = Cells(Rows.Count, "B").End(xlUp).row arr() = Range("A1:B" & lr).Value For i = 2 To UBound(arr) If arr(i, 1) = "" And arr(i, 2) <> "" Then arr(i, 1) = arr(i - 1, 1) End If Next i Range("A1:B" & lr).Value = arr() On Error Resume Next Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete On Error GoTo 0 Application.ScreenUpdating = True MsgBox "Готово!", vbInformation
End Sub
[/vba]
Макрос сделан под файл-пример. Предполагается, что шапки у таблицы нет (т.е. данные начинаются сразу со строки 1).
[vba]
Код
Sub Дублировать_и_Удалить_пустые()
Dim arr(), lr As Long, i As Long
Application.ScreenUpdating = False lr = Cells(Rows.Count, "B").End(xlUp).row arr() = Range("A1:B" & lr).Value For i = 2 To UBound(arr) If arr(i, 1) = "" And arr(i, 2) <> "" Then arr(i, 1) = arr(i - 1, 1) End If Next i Range("A1:B" & lr).Value = arr() On Error Resume Next Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete On Error GoTo 0 Application.ScreenUpdating = True MsgBox "Готово!", vbInformation
dd() With ActiveSheet.UsedRange With Intersect(.SpecialCells(xlCellTypeConstants, 23).EntireRow, .Columns) .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C1" End With .Formula = .Value .Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete .Cut [A1] End With End Sub
[/vba]
до кучи Sub [vba]
Код
dd() With ActiveSheet.UsedRange With Intersect(.SpecialCells(xlCellTypeConstants, 23).EntireRow, .Columns) .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C1" End With .Formula = .Value .Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete .Cut [A1] End With End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
