Loop too slow deleteing xltoleft

[MarcB]

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

 

[David Adamson]

The following below will only select the rows that actually have data in
them.

This means you won't have to check if there is data in other cells that you
have in your range.



Its probably not a hell of a lot of use in speeding up the large files
though.



With Worksheets(("SAP").

'The range is row 5, column 1 , ("a2")then find end of column by codes

Set rngcell = Range(.Cells(5, 1), .Cells(Rows.Count, 1).End(xlUp))

End with

 

[JWolf]

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

 

[JWolf]

Change line:
lastRow = Cells(Rows.Count, "A").End(xlUp).Row - 1 'Find last row
to:
lastRow = Cells(65536, 1).End(xlUp).Row 'Find last row

missed last line otherwise.

 

[MarcB]

Superb.
Many thanks to you both.

 

[MarcB]

Thanks for that. I worked that out after 5 go's of going what is wrong
with the last row??
Using the code which you supplied has given me an idea for the stage
before I get to remove the empty cells. Would you mind if I picked
your brain??? I think it could hopefuly be changing a few lines of
your code which you supplied.

My data in orginal format looks like this:
A B-j(all blank) K L
yyyy xxxx xxxx
yyyy xxxx xxxx
yyyy xxxx xxxx
yyyy xxxx xxxx
yyyy xxxx xxxx
yyyy xxxx xxxx
yyyy xxxx xxxx

I then run a macro which is slow (i thinking large calculation doesn't
help) which finds if there is a value in K, put in the formula
"=VLOOKUP(RC[1],setnode!C4:C5,2,FALSE)" in cells B-J.
I then value it and change the #n/a's to blank. Can you help? Sorry to
be a pain I like the lastrow you use instead of determining a
setting a range as i do.

Thanks again,
Marc

Sub SAP_hier1()


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

Sheets("SAP").Activate
Range("K2:K25000").Activate
For Each rngcell In Selection
If rngcell <> blank Then

rngcell.Offset(0, -1).FormulaR1C1 =
"=VLOOKUP(RC[1],setnode!C4:C5,2,FALSE)"
rngcell.Offset(0, -1).AutoFill
Destination:=Range(rngcell.Offset(0, -9), rngcell.Offset(0, -1)),
Type:=xlFillDefault

Range(rngcell.Offset(0, -9), rngcell.Offset(0, -1)).Copy
Range(rngcell.Offset(0, -9), rngcell.Offset(0, -1)).PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range(rngcell.Offset(0, -9), rngcell.Offset(0, -1)).Replace
"#N/A", Null


Else
End If
Next rngcell

Application.ScreenUpdating = True
End Sub