need to make code more efficient (if possible)

[Lilivati]

(Yes, I'm back again with another question, this group saves my life on
a daily basis... )

Anyway, I've never been a terribly efficient programmer, especially
with languages that are new to me (like VBA). Honestly I've never
really had to be; for most of the things I write memory resources are
more than adequate. However, most recently I've been working on a
"clean-up" macro for a long excel file spat out from a database. The
file is a massive parts list, and it has to be sorted and earlier
revisions of a part (essentially duplicates for the purposes of this
list) removed. The macro I wrote works well with shorter "test"
versions of the real list, and there's no reason why it shouldn't work
with the long list.

The issue is that the real list has ~56k rows. It takes 30 minutes for
just the first loop of the macro to execute. My machine is not the
best (256 MB RAM) but it is typical of the machines that will
ultimately use this macro. Running this macro also shoots my CPU usage
to 100% from about 1-3% when it is not running. What is baffling to me
is that this clean-up process is currently done by hand and it takes
fractions of a second to execute a command over the entire list that
way.

The whole idea behind adding this macro is to make the clean-up process
more efficient, and clearly that is not being accomplished if the macro
takes hours to finish.

The sub is called by pressing a button in another workbook (the
"cleaner" workbook that holds all my macros).

The first loop is necessary to sort the parts in correct numerical
order, but it really takes a long time. Is there any way to clean it
up? The sort and the second loop (which uses "i") are almost
instantaneous, then on the third loop (which uses "j") I get a "System
Error. The object invoked has disconnected from its clients." It is
definitely the third loop because if I comment it out I don't get this
error. As mentioned before this macro works in its entirety on a
smaller list.

The macro:

Sub Nassort()

Application.ScreenUpdating = False

'variable transfer from a userform to a worksheet (or from any A to B
in excel) is
'sketchy so I use a short hidden name function to move things around
instead
Dim nwb As String
nwb = GetHName("nassis")

'stupid formatting workaround, to make data numeric
With Workbooks(nwb).Worksheets(ws)
.Cells(2, 11).Copy
Dim k As Long
For k = 2 To .UsedRange.Rows.Count
.Cells(k, 3).PasteSpecial Paste:=xlAll, Operation:=xlAdd,
SkipBlanks:= _
False, Transpose:=False
Next k
End With

'sort the stuff by document and rev number
With Workbooks(nwb).Worksheets(ws)
.Range("A:F").sort _
Key1:=Workbooks(nwb).Worksheets(ws).Range("C2"), _
Order1:=xlAscending, _
Key2:=Workbooks(nwb).Worksheets(ws).Range("A2"), _
Order2:=xlAscending, _
Header:=xlYes, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom
End With


'NOTE: If you don't do it this way (if you delete directly)
'Excel will miss lower rev numbers when more than two revs
'exist for a given part number

'clear the row if it is a lower rev level
Dim i As Long
Dim j As Long
With Workbooks(nwb).Worksheets(ws)

For i = 2 To .UsedRange.Rows.Count
If .Cells(i + 1, 3) = .Cells(i, 3) Then
If .Cells(i, 1) = "" Then
'do nothing, rev level is blank
ElseIf .Cells(i + 1, 1) > .Cells(i, 1) Then
.Cells(i, 7) = "delete"
'.UsedRange.Rows(i).EntireRow.Clear
End If
End If
Next i

'delete blank rows created above
For j = UsedRange.Rows.Count To 2 Step -1
If .Cells(j, 7) = "delete" Then
'.Cells(j, 5) = "delete"
.UsedRange.Rows(j).EntireRow.Delete
End If
Next j

End With

Application.ScreenUpdating = True

End Sub


Any ideas?

 

[Bernie Deitrick]

Try not to loop when you don't need to:

With Workbooks(nwb).Worksheets(ws)
.Cells(2, 11).Copy
Dim k As Long
For k = 2 To .UsedRange.Rows.Count
.Cells(k, 3).PasteSpecial Paste:=xlAll, Operation:=xlAdd,
SkipBlanks:= _
False, Transpose:=False
Next k
End With

Could be:

With Workbooks(nwb).Worksheets(ws)
.Cells(2, 11).Copy
.Range(.Cells(2, 3), .Cells(.UsedRange.Rows.Count, 3)).PasteSpecial Paste:=xlAll, _
Operation:=xlAdd, SkipBlanks:=False, Transpose:=False
End With


And for the deletion, it is much faster to do it this way:

Dim myRow As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With

With Workbooks(nwb).Worksheets(ws)
myRow = .UsedRange.Rows.Count
..Range("G1").VAlue = "Keep/Delete"
..Range("G2").Formula = _
"=IF(A3>A2,""Delete"","""")"
..Range("G2").AutoFill Destination:=.Range("G2:G" & myRow)
..Cells.Sort key1:=.Range("G2"), order1:=xlDescending, Header:=xlYes
With .Range("G:G")
.AutoFilter Field:=1, Criteria1:="Delete"
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
.EntireColumn.Delete
End With
End With

With Application
.ScreenUpdating = True
.EnableEvents = True
End With

End Sub

HTH,
Bernie
MS Excel MVP

 

[Bill Schanks]

I would also recommend, making calculation manual while this is running
and turning it back on when done:

At the beginning:
Application.Calculation = xlCalculationManual

At the end:
Application.Calculation = xlCalculationAutomatic

Also, I always try to put in error handling and a common exit point. I
would put the command to put calculation back to automatic in the exit
routine that way it is always turned back on when an error occurs.

 

[Bernie Deitrick]

Bill,

The code that I posted relies on calculations being on - otherwise the formulas don't properly
reflect the sheet content.

HTH,
Bernie
MS Excel MVP

 

[Bill Schanks]

My apolgies

Bill,

The code that I posted relies on calculations being on - otherwise the formulas don't properly
reflect the sheet content.

HTH,
Bernie
MS Excel MVP

 

[Bernie Deitrick]

Bill,

No apology needed - just wanted to make sure that the OP wasn't confused on the issue.

Bernie
MS Excel MVP

 

[Lilivati]

Bernie-

Thanks very much! After a few tweaks it is sorting out the data and
deleting the appropriate rows beautifully. There is still one small
problem however- when I try to delete the helper columns, for some
reason the rows do not delete (I still have the whole list). Also, the
"G" column does not really delete, but keeps its header and the entire
column is filled with #REF indicating some kind of formula error.

Here is the relevant portion of my modified macro:

Dim myRow As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With

With Workbooks(nwb).Worksheets(ws)
myRow = .UsedRange.Rows.Count
.Range("G1").Value = "Counter"
.Range("G2").Formula = "=IF(C2=C1,1+G1,0)"
.Range("G2").AutoFill
Destination:=Workbooks(nwb).Worksheets(ws).Range("G2:G" & myRow)

.Range("H1").Value = "Keep/Delete"
.Range("H2").Formula = "=IF(G3>G2,""Delete"",""Keep"")"
.Range("H2").AutoFill
Destination:=Workbooks(nwb).Worksheets(ws).Range("H2:H" & myRow)

.Range(.Cells(2, 8), .Cells(.UsedRange.Rows.Count, 8)).Copy
.Range(.Cells(2, 9), .Cells(.UsedRange.Rows.Count, 9)).PasteSpecial
Paste:=xlValues, _
SkipBlanks:=False, Transpose:=False

.Cells.sort _
key1:=Workbooks(nwb).Worksheets(ws).Range("I2"), _
order1:=xlDescending, _
Key2:=NONE, _
Order2:=xlAscending, _
Header:=xlYes
With .Range("I:I")
.AutoFilter Field:=1, Criteria1:="Keep"
.Cells(xlCellTypeVisible).EntireRow.Delete
End With

.Range("G:G").EntireColumn.Delete
.Range("H:H").EntireColumn.Delete
.Range("I:I").EntireColumn.Delete

End With

With Application
.ScreenUpdating = True
.EnableEvents = True
End With


Notes:

I had to add an additional formula, or it was deleting parts that were
not the same but had different rev levels. Also, I had to copy the
values of the delete/keep column to a new column, or they would change
when the cells were sorted as the formula updated itself.

The original filter criteria you specified led to the deletion of the
cells I wanted to keep, so I simply flipped it. Furthermore I am
deleting more cells than the SpecialCells function can handle, so I
changed this to simply Cells.

On the entire columns deletions, I tried this inside the With Range as
well as outside, and both tries result in the error described above.

Thanks again!

 

[Bernie Deitrick]

See my comments in-line...

HTH,
Bernie
MS Excel MVP

Thanks very much! After a few tweaks it is sorting out the data and
deleting the appropriate rows beautifully. There is still one small
problem however- when I try to delete the helper columns, for some
reason the rows do not delete (I still have the whole list). Also, the
"G" column does not really delete, but keeps its header and the entire
column is filled with #REF indicating some kind of formula error.

Sounds like you are deleting the wrong column - but try my suggestions and see what happens....

Here is the relevant portion of my modified macro:
With Workbooks(nwb).Worksheets(ws)
myRow = .UsedRange.Rows.Count
.Range("G1").Value = "Counter"
.Range("G2").Formula = "=IF(C2=C1,1+G1,0)"
.Range("G2").AutoFill
Destination:=Workbooks(nwb).Worksheets(ws).Range("G2:G" & myRow)

.Range("H1").Value = "Keep/Delete"
.Range("H2").Formula = "=IF(G3>G2,""Delete"",""Keep"")"
.Range("H2").AutoFill
Destination:=Workbooks(nwb).Worksheets(ws).Range("H2:H" & myRow)

Try changing these two lines below:

.Range(.Cells(2, 8), .Cells(.UsedRange.Rows.Count, 8)).Copy
.Range(.Cells(2, 9), .Cells(.UsedRange.Rows.Count, 9)).PasteSpecial
Paste:=xlValues, _
SkipBlanks:=False, Transpose:=False

to:

.Range("G:H").Copy
.Range("G:H").PasteSpecial Paste:=xlValues

and sort on H rather than I:
key1:=Workbooks(nwb).Worksheets(ws).Range("H2"), _

.Cells.sort _
key1:=Workbooks(nwb).Worksheets(ws).Range("I2"), _
order1:=xlDescending, _
Key2:=NONE, _
Order2:=xlAscending, _
Header:=xlYes

And instead of filtering on H, try

Dim myF As Range

Set myF = Range("H:H").Find("Keep")
Range(myF, myF.End(xlDown)).EntireRow.Delete


Remove this.....

With .Range("I:I")
.AutoFilter Field:=1, Criteria1:="Keep"
.Cells(xlCellTypeVisible).EntireRow.Delete
End With

and try this for the column deletion:

.Range("G:H").Delete

 

[Lilivati]

That worked brilliantly. Thanks a bunch!

See my comments in-line...

HTH,
Bernie
MS Excel MVP


Sounds like you are deleting the wrong column - but try my suggestions and see what happens....


Try changing these two lines below:


to:

.Range("G:H").Copy
.Range("G:H").PasteSpecial Paste:=xlValues

and sort on H rather than I:
key1:=Workbooks(nwb).Worksheets(ws).Range("H2"), _


And instead of filtering on H, try

Dim myF As Range

Set myF = Range("H:H").Find("Keep")
Range(myF, myF.End(xlDown)).EntireRow.Delete


Remove this.....

and try this for the column deletion:

.Range("G:H").Delete