Excel Macro Find Text value Cut and Paste then shift cells up - excel

Question

I have a nightmare task to migrate from one accounting package to another.
I have 9340 rows in columns A,B and G which needs to be ordered in a certain way before it can be imported by new system.
Before:
After:
I ran a macro that does what I want but only for selected range. How do I make macro work for entire sheet?
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

This will likely fail in some respect. Your setup is more complicated than I have time to re-create. Please run this code on a copy of your data. It basically moves things around and then deletes all the rows that have blanks in column B. You should delete the header junk above the first "Opening" row:
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