Excel Macro Найти текстовое значение Вырезать и вставить, а затем сдвинуть ячейки вверх

Question

У меня есть задача кошмара перейти от одного пакета учета к другому.

У меня есть 9340 строк в столбцах A, B и G, которые необходимо заказать определенным образом, прежде чем они могут быть импортированы новой системой.

До:

После:

Я побежал макрос, который делает то, что я хочу, но только для выбранного диапазона. Как сделать макрос для всего листа?

Sub Macro1() 

    Range("B206").Select 
    Selection.Cut 
    Range("A207").Select 
    ActiveSheet.Paste 
    Rows("206:206").Select 
    Selection.Delete Shift:=xlUp 
    Range("A206").Select 
    Selection.Copy 
    Range("A206:A216").Select 
    ActiveSheet.Paste 
    Range("C216").Select 
    Application.CutCopyMode = False 
    Selection.Cut 
    Range("G216").Select 
    ActiveSheet.Paste 
End Sub 

Answer 1

Это, скорее всего, не сработает. Ваша настройка сложнее, чем у меня есть время для воссоздания. Пожалуйста, запустите этот код на копия ваших данных. Это в основном движется все вокруг, а затем удаляет все строки, которые имеют пробелы в столбце B. Вы должны удалить мусор заголовка над первым «Открытие» строки:

Sub test() 
Dim ws As Excel.Worksheet 
Dim LastRow As Long 
Dim cell As Excel.Range 

Set ws = ActiveSheet 
With ws 
LastRow = .Range("B" & .Rows.Count).End(xlUp).Row 
For Each cell In .Range("B1:B" & LastRow) 
    If Left(cell.Value, Len("Opening")) = "Opening" Then 
     cell.Offset(1, -1).Value = cell.Value 
     cell.ClearContents 
    Else 
     cell.Offset(0, -1) = cell.Offset(-1, -1).Value 
    End If 
    If Left(cell.Value, Len("Closing")) = "Closing" Then 
     cell.Offset(0, 6).Value = cell.Offset(0, 1).Value 
     cell.Offset(0, 1).ClearContents 
    End If 
Next cell 
    .Range("B" & .Rows.Count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete 
End With 
End Sub