How to speed up this macro?

  • Thread starter Thread starter Ctech
  • Start date Start date
C

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
 
This should dramatically reduce your working time, and dont forget to declare your variables.

Sub IfLetterThen
Dim MyFirst, MyLast as string
Dim t as variant
application.screenupdating = false
for each t in range(Myfirst, MyLast)
if t.value = "AP" then range(t.address).offset(0,14).delete Shift:=xlToLeft
if t.value = "GL" then range(t.address).offset(0,12).delete shift:=xltoleft
Next
End Sub

This should be enough code to replace all the code you have above.
 
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
 
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
|
 
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
 
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)
 
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
 
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
 
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


Bernie Deitrick said:
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
Click to expand...
 
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
 
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
 
Ctech,
You are a legend
Click to expand...

Only in my own mind ;-)
I have the VBA Excel macroes for Dummies, do you have a more advanced
book which you would recommend?
Click to expand...

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
 
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
 
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
 
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
 
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
 
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.
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Can Vba workout if a selection is part of a group? 0
Variable counting of rows 7
Excel Macro to use cells as a autofilter 0
Hlp! Adv Filter - Non-Contiguous rows don't copy 11
Run-time error 1004 paste method of worksheet class failed 3
Macro working on my pc but no one else's 8
Inserting 2 columns when cells don't match 6
Create Detail Sheets from Pivot Table 1

Back
Top