How to speed up this macro?

[Ctech]

Hi,

I've new to this VBA stuff, however with my limited knowledge have I
made a macro which adds cells and delete cells depeding on the text in
the first cell of the row.

My main problem is that it takes ages, as my spreadsheet have 25.000
rows.
I guess it would become quicker if I sorted all rows on the first cell,
then marked all rows including "AP" in first cell and then add the cell
needed.

Would it be possible to get this macro time down to a minute or two
instead of 60+ which is it now.

Thanks guys.


The macro:

Sub IfLetterThen()

Application.ScreenUpdating = False

For i = 1 To 100

If IsEmpty(ActiveCell) = False Then

' 2003

If ActiveCell = "AP" Then

ActiveCell.Offset(0, 14).Range("A1").Select
Selection.Delete Shift:=xlToLeft
ActiveCell.Offset(0, -14).Range("A1").Select



ElseIf ActiveCell = "GL" Then
ActiveCell.Offset(0, 12).Range("A1").Select
Selection.Delete Shift:=xlToLeft
ActiveCell.Offset(0, -12).Range("A1").Select


End If
End If

ActiveCell.Offset(1, 0).Select

Next i

Application.ScreenUpdating = True

End Sub

 

[Ctech]

Is there now way to speed this up?

 

[Bernie Deitrick]

Ctech,

You need to explain what you want to do a little bit more. Why are you only looping through 100
times? Is your worksheet a single data table, or a number of data tables whose structure would be
damaged if the whole sheet were sorted?

HTH,
Bernie
MS Excel MVP

 

[Jim Rech]

I didn't try this on a range as big as yours (25k rows) but it worked on
1000 rows quickly.

Select the range that includes the APs and GLs, like A1:A25000, and then run
this:

Option Compare Text

Dim DelRg As Range

Sub DelCells()
Dim Cell As Range
Set DelRg = Nothing
For Each Cell In Selection.SpecialCells(xlCellTypeConstants)
If Cell.Value = "AP" Then
AddToUnion Cell.Offset(0, 14)
ElseIf Cell.Value = "GL" Then
AddToUnion Cell.Offset(0, 12)
End If
Next
If Not DelRg Is Nothing Then DelRg.Delete xlToLeft
End Sub

Sub AddToUnion(Cell As Range)
If DelRg Is Nothing Then
Set DelRg = Cell
Else
Set DelRg = Union(DelRg, Cell)
End If
End Sub


--
Jim
message |
| Hi,
|
| I've new to this VBA stuff, however with my limited knowledge have I
| made a macro which adds cells and delete cells depeding on the text in
| the first cell of the row.
|
| My main problem is that it takes ages, as my spreadsheet have 25.000
| rows.
| I guess it would become quicker if I sorted all rows on the first cell,
| then marked all rows including "AP" in first cell and then add the cell
| needed.
|
| Would it be possible to get this macro time down to a minute or two
| instead of 60+ which is it now.
|
| Thanks guys.
|
|
| The macro:
|
| Sub IfLetterThen()
|
| Application.ScreenUpdating = False
|
| For i = 1 To 100
|
| If IsEmpty(ActiveCell) = False Then
|
| ' 2003
|
| If ActiveCell = "AP" Then
|
| ActiveCell.Offset(0, 14).Range("A1").Select
| Selection.Delete Shift:=xlToLeft
| ActiveCell.Offset(0, -14).Range("A1").Select
|
|
|
| ElseIf ActiveCell = "GL" Then
| ActiveCell.Offset(0, 12).Range("A1").Select
| Selection.Delete Shift:=xlToLeft
| ActiveCell.Offset(0, -12).Range("A1").Select
|
|
| End If
| End If
|
| ActiveCell.Offset(1, 0).Select
|
| Next i
|
| Application.ScreenUpdating = True
|
| End Sub
|
|
| --
| Ctech
| ------------------------------------------------------------------------
| Ctech's Profile:
http://www.excelforum.com/member.php?action=getinfo&userid=27745
| View this thread: http://www.excelforum.com/showthread.php?threadid=472537
|

 

[Ctech]

Im counting just the first 100 because its just for testing purposes..
so 100 will be changed to the total number of rows in the sheet. ( I
need to add a count rows, too)

The macro isn't perfectly right at the moment!!

I want the macro to go through the whole spreadsheet and give all rows
the same number of columns. As it all is to be changed into a
pivottable later.

In my spreadsheet, all lines starting with "AP" have a row to much and
all starting with GL have one column to little. (So this is what my
macro mainly have to do something with)


Thanks

 

[Ctech]

Thanks, Im working on it now..


Let say the Cell contains i.e AP JGLP, and I want this to be considered
as AP by the macro. Is there a way to write Cell.Value = "AP %"
where % means random letters?

If Cell.Value = "AP" Then
AddToUnion Cell.Offset(0, 14)

 

[Bernie Deitrick]

Ctechm

Try the macro below, which sorts to get like values together. It will speed it up considerably.

I think I got your logic correct, but try it first on a copy of your data.

Note that the table could be resorted as a final step - you would need to determine the sort basis,
though.

HTH,
Bernie
MS Excel MVP

Sub IfLetterThen()
Dim myRows As Long
Range("A1").EntireColumn.Insert

'Find AP and delete extra column
Range("A1").FormulaR1C1 = _
"=IF(RC[1]=""AP"",""SortLow"",""SortHigh"")"
myRows = ActiveSheet.UsedRange.Rows.Count
Range("A1").Copy Range("A1:A" & myRows)
With Range(Range("A1"), Range("A1").End(xlDown))
.Copy
.PasteSpecial Paste:=xlValues
End With
Cells.Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending
Columns("A:A").Find(What:="SortLow", After:=Range("A1")).Select
Range(Selection, Selection.End(xlDown)).Offset(0, 14).Delete Shift:=xlToLeft

'Find GL and insert extra column
Range("A1").FormulaR1C1 = _
"=IF(RC[1]=""GL"",""SortLow"",""SortHigh"")"
Range("A1").Copy Range("A1:A" & myRows)
With Range(Range("A1"), Range("A1").End(xlDown))
.Copy
.PasteSpecial Paste:=xlValues
End With
Cells.Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending
Columns("A:A").Find(What:="SortLow", After:=Range("A1")).Select
Range(Selection, Selection.End(xlDown)).Offset(0, 12).Insert Shift:=xlToRight
Range("A1").EntireColumn.Delete
End Sub

 

[Ctech]

Thanks your macro works, however I want to add a column for GL and not
delete one like your macro do. Could you help me fix this. Thanks

 

[Tom Ogilvy]

if cell.Value like "AP*" Then

or

if left(cell.Value,2) = "AP" then

 

[Bernie Deitrick]

In light of your other statements, change

Range("A1").FormulaR1C1 = _
"=IF(RC[1]=""AP"",""SortLow"",""SortHigh"")"

to

Range("A1").FormulaR1C1 = _
"=IF(LEFT(RC[1],2)=""AP"",""SortLow"",""SortHigh"")"

Same for the GL line....

HTH,
Bernie
MS Excel MVP

Ctechm

Try the macro below, which sorts to get like values together. It will speed it up considerably.

I think I got your logic correct, but try it first on a copy of your data.

Note that the table could be resorted as a final step - you would need to determine the sort
basis, though.

HTH,
Bernie
MS Excel MVP

Sub IfLetterThen()
Dim myRows As Long
Range("A1").EntireColumn.Insert

'Find AP and delete extra column
Range("A1").FormulaR1C1 = _
"=IF(RC[1]=""AP"",""SortLow"",""SortHigh"")"
myRows = ActiveSheet.UsedRange.Rows.Count
Range("A1").Copy Range("A1:A" & myRows)
With Range(Range("A1"), Range("A1").End(xlDown))
.Copy
.PasteSpecial Paste:=xlValues
End With
Cells.Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending
Columns("A:A").Find(What:="SortLow", After:=Range("A1")).Select
Range(Selection, Selection.End(xlDown)).Offset(0, 14).Delete Shift:=xlToLeft

'Find GL and insert extra column
Range("A1").FormulaR1C1 = _
"=IF(RC[1]=""GL"",""SortLow"",""SortHigh"")"
Range("A1").Copy Range("A1:A" & myRows)
With Range(Range("A1"), Range("A1").End(xlDown))
.Copy
.PasteSpecial Paste:=xlValues
End With
Cells.Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending
Columns("A:A").Find(What:="SortLow", After:=Range("A1")).Select
Range(Selection, Selection.End(xlDown)).Offset(0, 12).Insert Shift:=xlToRight
Range("A1").EntireColumn.Delete
End Sub

 

[Tom Ogilvy]

Sub DelCells()
Dim DelRg As Range
Dim DelRg1 As Range
Dim Cell As Range
Set DelRg = Nothing
Set DelRg1 = Nothing
For Each Cell In Selection.SpecialCells(xlCellTypeConstants)
If Cell.Value Like "AP*" Then
AddToUnion Cell.Offset(0, 14), DelRg
ElseIf Cell.Value Like "GL*" Then
AddToUnion Cell.Offset(0, 12), DelRg1
End If
Next
If Not DelRg Is Nothing Then DelRg.Delete xlToLeft
If Not DelRg1 Is Nothing Then DelRg1.Insert Shift:=xlShiftToRight

End Sub

Sub AddToUnion(Cell As Range, rng As Range)
If rng Is Nothing Then
Set rng = Cell
Else
Set rng = Union(rng, Cell)
End If
End Sub

 

[Ctech]

Bernie Deitric

You are a legend, thanks it works perfect and takes like 5 sec to
do...

I have the VBA Excel macroes for Dummies, do you have a more advanced
book which you would recommend?


Again Thanks

 

[Bernie Deitrick]

Ctech,

You are a legend

Only in my own mind ;-)

I have the VBA Excel macroes for Dummies, do you have a more advanced
book which you would recommend?

A good next step is John Walkenbach's Excel 2003 Power Programming With VBA. Also written for
earlier versions, though not much changes between versions, so any book in that series is good.

HTH,
Bernie
MS Excel MVP

 

[Ctech]

OK guys, I've been working quite a bit on my macro now, which is to d
what I explained earlier in this post.

So far it doesn't work, but I'm working on it.. if someone believes I
totally of track with what I've done so far, please let me know.

Remember I working on a 20.000 + row sheet. So it needs to be quick...


Code so far:

Sub Macro1()
'
' Macro1 Macro
' Macro recorded 04/10/2005 by Taylor Nelson Sofres plc
'

'

Dim DelRg As Range


' Sort the table after Cost Centres (CC) and then after Supplier


Selection.Sort Key1:=Range("H2"), Order1:=xlAscending
Key2:=Range("I2") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1
MatchCase:= _
False, Orientation:=xlTopToBottom

' Setting the different Sup = Supplier - CC = Cost Centre

Set Sup = Nothing
Set CC = Nothing
Set RC = Nothing
' Selects the first cell in the cost centre column

Range("H2").Select

For Each Cell In Range("H:H")

' Sets active Cell = CC

ActiveCell.Value = CC
ActiveCell.Offset(0, 1) = Sup

ActiveCell.Offset(1, 0).Select

' Add next row to range if it is the same CC and suppliers as the ro
above

If ActiveCell.Value = CC And ActiveCell.Offset(0, 1) = Sup Then
AddToUnion Cell.Offset(0, 2), DelRg

' If Row is not equal to the one above then check if Total sum o
Range = 0

ElseIf Not ActiveCell.Value = CC And ActiveCell.Offset(0, 1) = Su
Then

' Check if Range is Nothing

If Not DelReg Is Nothing Then
DelReg.Select

' If Row Total is = 0 then delete Range

If Range.Subtotal = 0 Then
Range.EntireRow.Select.Delete x1ToLeft

End If
End If

' Checks if the cell is blank if it is GoTo End

ElseIf IsEmpty(ActiveCell) Then GoTo TheEnd
End If

Next Cell

TheEnd:
MsgBox ("All Suppliers under Cost centres which adds up to 0 is no
deleted.")


End Su

 

[Bernie Deitrick]

Ctech,

Never step through row by row if you can help it.

Try the macro below. This looks at the values in column I (which, as close as I can tell, is your
basis) and looks for the values in column J to sum, and deletes rows when column J sums to 0 for any
value of column I. If that isn't the case, then you need to better describe the basis for row
deletion.

This took about 20 seconds to do 22000 rows on my rather slow machine.

HTH,
Bernie
MS Excel MVP


Sub Delete0Sums()
Dim myRows As Long
Range("A1").EntireColumn.Insert
myRows = Range("B65536").End(xlUp).Row
'Sum column J based on column I
Range("A1").Value = "Delete Row criterian"
Range("A2").FormulaR1C1 = _
"=IF(SUMIF(C[9],RC[9],C[10])=0,""SortLow"",""SortHigh"")"
Range("A2").Copy Range("A2:A" & myRows)
With Range("A:A")
.Copy
.PasteSpecial Paste:=xlValues
End With
Cells.Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending
Columns("A:A").Find(What:="SortLow", After:=Range("A1")).Select
Range(Selection, Selection.End(xlDown)).EntireRow.Delete
Range("A1").EntireColumn.Delete
End Sub

 

[Ctech]

After 3 days of working with my limited knowledge in VBA, You come up
with this genius macro...

Can I ask you to explain (line by line) what this macro does, because I
don't understand by looking at it.


Thanks

 

[Ctech]

I have attached a picture of the spreadsheet.


+-------------------------------------------------------------------+
|Filename: Untitled-2.png |
|Download: http://www.excelforum.com/attachment.php?postid=3884 |
+-------------------------------------------------------------------+

 

[Bernie Deitrick]

Sub Delete0Sums()
Dim myRows As Long

'Insert a new column A for a formula that will categorize each row
'Note that all other columns are then pushed over, so are one column higher
Range("A1").EntireColumn.Insert

'Count the rows
myRows = Range("B65536").End(xlUp).Row

'Sum column J based on column I
'Put in a temp heading (mis-spelling and all...)
Range("A1").Value = "Delete Row criterian"
'=IF(SUMIF(J:J,J2,K:K)=0,"SortLow","SortHigh")
'Put this formula into cell A2
'=IF(SUMIF(J:J,J2,K:K)=0,"SortLow","SortHigh")
'Sums the values from old column J for matching values in old column I
Range("A2").FormulaR1C1 = _
"=IF(SUMIF(C[9],RC[9],C[10])=0,""SortLow"",""SortHigh"")"
'Copy the formula down to match your range
Range("A2").Copy Range("A2:A" & myRows)
'Convert the formulas to values
With Range("A:A")
.Copy
.PasteSpecial Paste:=xlValues
End With
'Select everything for the sort
Cells.Select
Sort based on column A
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending
'Find the first value that should be deleted - sorts to the bottom,
'so once found, we can just do an end down selection to get them all
Columns("A:A").Find(What:="SortLow", After:=Range("A1")).Select
'Delete all the rows that have SortLow in column A
Range(Selection, Selection.End(xlDown)).EntireRow.Delete
'Get rid of column A since you don't need it any more
Range("A1").EntireColumn.Delete
End Sub

 

[Ctech]

This helped a lot, however I don't understand how this code

Range("A2").FormulaR1C1 = _
"=IF(SUMIF(C[9],RC[9],C[10])=0,""SortLow"",""SortHigh"")"

works

I guess:
C=[9] = Column 9 from A ("I:I" - Cost center column)
RC[9] = Cell 9 from A ("I?" - Cost center)
C[10] = Column 10 from A ("J:J" - Supplier column)

How does this Sum column K (Func_Value coulmn)?

Could you explain this, even more? I have read the SUMIF help on Excel,
however it didn't help much.


Thanks so far for all the help.

 

[Bernie Deitrick]

Ctech,

This code:

Range("A2").FormulaR1C1 = _
"=IF(SUMIF(C[9],RC[9],C[10])=0,""SortLow"",""SortHigh"")"

C[9] means 9 columns to the right of the current column (A), so C[9] = J:J, C[10] = K:K

Creates this formula:

=IF(SUMIF(J:J,J2,K:K)=0,"SortLow","SortHigh")

This part

SUMIF(J:J,J2,K:K)

returns the sum from column K (Your initial column J) where the value in column J (your initial
column I) is the same as that of the current row.

Lets say that column J and K has these values

Bernie 5
Ctech 4
Fred 0
Bernie 6
Ctech 4
Fred 0

The SUMIF would return values like this:

11 Bernie 5
8 Ctech 4
0 Fred 0
11 Bernie 6
8 Ctech 4
0 Fred 0

But the IF function would change those to

SortHigh Bernie 5
SortHigh Ctech 4
SortLow Fred 0
SortHigh Bernie 6
SortHigh Ctech 4
SortLow Fred 0

Which, when sorted, would be

SortHigh Bernie 5
SortHigh Ctech 4
SortHigh Bernie 6
SortHigh Ctech 4
SortLow Fred 0
SortLow Fred 0

Then the bottom two rows would be deleted.

HTH,
Bernie
MS Excel MVP

This helped a lot, however I don't understand how this code

Range("A2").FormulaR1C1 = _
"=IF(SUMIF(C[9],RC[9],C[10])=0,""SortLow"",""SortHigh"")"

works

I guess:
C=[9] = Column 9 from A ("I:I" - Cost center column)
RC[9] = Cell 9 from A ("I?" - Cost center)
C[10] = Column 10 from A ("J:J" - Supplier column)

How does this Sum column K (Func_Value coulmn)?

Could you explain this, even more? I have read the SUMIF help on Excel,
however it didn't help much.


Thanks so far for all the help.