Удаление пустых строк в excel и перенос строк в соседний стобец

[Brandon Lang]

Есть длинный список.... в котором есть пустые строки, которые надо удалить. Это первая задача.
Затем каждую вторую строчку, получается, надо перенести во второй столбец напротив первой надписи в первом столбце.
Список длинный, порядка нескольких тысяч строк. Руками до пенсии переносить придется.

[zs5]

значение матрицы 1.1 = первому значению данного массива,
а далее в первом столбце формула (с ячейки 1.2): =ИНДЕКС($A$1:$A$7;ПОИСКПОЗ(C1;$A$1:$A$7;0)+4;1)
во втором столбце формула (с ячейки 1.1): =ЕСЛИ(ОСТАТ(ПОИСКПОЗ(C1;$A$1:$A$7;0);2)/2>0;ИНДЕКС($A$1:$A$7;ПОИСКПОЗ(C1;$A$1:$A$7;0)+2;1);"")
С уважением, ZS

[Brandon Lang]

Мне посоветовали в VBA так сделать. Но там после запуска скрипта он не останавливается  и файл зацикливается

Код Выделить Развернуть

Sub forma()
i = 1
pair = False
Do
If Trim(Cells(i, 1)) <> "" Then
i = i + 1
pair = False
Else
Rows(i).Select
Selection.Delete Shift:=xlUp
If Cells(i, 1) <> "" And Not pair Then
Cells(i - 1, 2) = Cells(i, 1)
Cells(i, 1) = ""
pair = True
End If
End If
Loop While i < 10000
End Sub

[zs5]

формула работает только на тех строчках, что укажет оператор

[boa]

Думаю, по комментам понятно что и зачем

Код Выделить Развернуть

Sub NewTabl()
Dim sht As Worksheet
Dim userData()  'массив для занесения данных с листа
Dim i&
Dim arrRezult()

Set sht = ActiveSheet
userData = sht.UsedRange
' в начале удаляем пустые строки начиная с конца, что бы не зациклиться :)
    For i = UBound(userData, 1) To LBound(userData, 1) Step -1
        If Application.WorksheetFunction.CountA(sht.Rows(i)) = 0 Then
           sht.Rows(i).Delete xlUp
        End If
    Next i
userData = sht.UsedRange
'задаем размер массива с результирующими данными
ReDim arrRezult(1 To ((UBound(userData, 1) \ 2) + 1), 1 To 2)              'обратный слешь возвращает целое число от деления
'наполняем массив данными
    For i = LBound(userData, 1) To UBound(userData, 1) Step 2
        arrRezult((i + 2) \ 2, 1) = userData(i, 1)
        If UBound(userData, 1) = i Then
            arrRezult((i + 2) \ 2, 2) = ""
        Else
            arrRezult((i + 2) \ 2, 2) = userData(i + 1, 1)
        End If
    Next i
sht.UsedRange.ClearContents 'очистим то, что было
'возвращаем данные на лист в два столбца
sht.Range("A1").Resize(UBound(arrRezult, 1), 2) = arrRezult
End Sub
Для ускорения работы макроса при обработке большого массива данных, я бы еще добавил отключение обновления экрана и обработку событий листа

Код Выделить Развернуть

Application.ScreenUpdating = False
Application.EnableEvents = False
...
...
Application.ScreenUpdating = True
Application.EnableEvents = True