Try this macro on a copy of your worksheet:

Sub test()
Dim lastRow As Long
Dim myRange
Dim i As Long, j As Integer, k As Integer
Dim test As Boolean
Application.ScreenUpdating = False
Sheets("SAP").Activate
lastRow = Cells(Rows.Count, "A").End(xlUp).Row - 1 'Find last row
ReDim myRange(2 To lastRow, 1 To 7) 'size array
For i = 2 To lastRow 'fill array myRange by row
For j = 1 To 7 'fill array by column
myRange(i, j) = Cells(i, j).Value 'actual fill
Next j
Next i
For i = 2 To lastRow 'cycle through each row
If myRange(i, 1) < "" Then 'check if column a is filled
For j = 2 To 7 'cycle through columns
If myRange(i, 2) = "" Then test = True 'is "B" empty?
Do While test = True 'do while "B" is empty
For k = 2 To 6 'then shift cells from right
myRange(i, k) = myRange(i, k + 1)
If myRange(i, 7) = "" Then test = False
'Prevents endless loop in empty line
Next k
myRange(i, 7) = "" 'empty cell "G"
If myRange(i, 2) < "" Then test = False ' "B"
is now filled
Loop
Next j
End If
Next i
Range(Cells(2, 1), Cells(lastRow, 7)).ClearContents 'Clear original
range
Range(Cells(2, 1), Cells(lastRow, 7)) = myRange 'Fill original
range with new values
Application.ScreenUpdating = True
End Sub


MarcB wrote:
Good afternoon,

I am re-creating a SAP profit centre hierarchy in excel.
Previous macros that i use will put data in columns A to column G.
This will give me a spreadsheet that looks like this:
Assume y's and x's are 10 digit number/letters

A B C D E F G
yyyyy xxxxx xxxxx xxxxx xxxxx xxxxx
yyyyy xxxxx xxxxx xxxxx xxxxx
yyyyy xxxxx
yyyyy xxxxx xxxxx
yyyyy xxxxx xxxxx xxxxx xxxxx xxxxx xxxxx
yyyyy xxxxx xxxxx xxxxx xxxxx xxxxx xxxxx
yyyyy xxxxx xxxxx xxxxx

The macro, attached below, I have written checks to see if there is
anything in column A and if nothing in col B then delete left till
column B has a value. Then move onto the next row.
The problem is that it is too slow, over 9 mins, for it too process
anything between 4000 and 25000 rows.

Can you please help and include comments so that I can learn.

Ta,

Marc

Sub parent_alignment()

Application.StatusBar = "SAP hierarchy alignment"

Application.ScreenUpdating = False
On Error Resume Next
Dim rngcell As Range

Sheets("SAP").Activate
Range("A2:A25000").Activate
For Each rngcell In Selection
If rngcell < blank And rngcell.Offset(0, 1) = blank Then

Do Until rngcell.Offset(0, 1) < blank
rngcell.Offset(0, 1).Delete Shift:=xlToLeft

Loop

End If

Next rngcell
Application.StatusBar = "All done"
Application.ScreenUpdating = True

End Sub