Slow Code

S

Shawn

Below is a code that works great, but is very slow. I made this a three step
code but am fairly certain that a more skilled programmer could fine tune
this into a single step quicker process. Below is the code and I will take
suggestions on new code. Thanks in advance:

Public Sub UniqueValues()

'Searches target range and returns unique values to desired column

Dim Col As Collection
Dim Arr() As Variant
Dim rCell As Range
Dim rng As Range
Dim i As Long
Dim WB As Workbook
Dim sh1 As Worksheet
Dim ShUnVa As Worksheet

Set WB = ActiveWorkbook
Set sh1 = WB.Sheets("Sheet1")
Set ShUnVa = WB.Sheets("UniqueValues")
Set Col = New Collection
Set rng = sh1.Range(sh1.Range("F2"), sh1.Range("GI32").End(xlDown))
Set rng = rng.Resize(, 186)



ShUnVa.Select
ShUnVa.Columns("A:A").Delete Shift:=xlToLeft


For Each rCell In rng.Cells
If Not IsEmpty(rCell.Value) Then
On Error Resume Next
Col.Add rCell.Value, CStr(rCell.Value)
On Error GoTo 0
End If
Next rCell
On Error Resume Next
ReDim Arr(1 To Col.Count)

For i = LBound(Arr, 1) To UBound(Arr, 1)
Arr(i) = Col.Item(i)
Next i

ShUnVa.Range("A1").Resize(i - 1) = Application.Transpose(Arr)

'Sorts the unique values in ascending order

ShUnVa.Columns("A:A").Sort Key1:=Range("A1"), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

'If the first value is zero it deletes it

If ShUnVa.Range("A1").Value = 0 Then ShUnVa.Range("A1").Delete Shift:=xlUp

'Converts the unique values to provider numbers


Dim strConProNum As String
ShUnVa.Range("A1").Select
ShUnVa.Range("A1").Activate
Do Until ActiveCell.Value = ""
strConProNum = ActiveCell.Value

If ActiveCell.Value < 200000 Then
ActiveCell.Value = ActiveCell.Value - 100000
Else
ActiveCell.Value = ActiveCell.Value - 200000
End If
ActiveCell.Offset(1, 0).Select
Loop



'Gets the unique values from the converted data sorts them and moves them to
column A

Dim Col2 As Collection
Dim Arr2() As Variant
Dim rCell2 As Range
Dim rng2 As Range
Dim i2 As Long

Set Col2 = New Collection
Set rng2 = ShUnVa.Range("A:A")


For Each rCell2 In rng2.Cells
If Not IsEmpty(rCell2.Value) Then
On Error Resume Next
Col2.Add rCell2.Value, CStr(rCell2.Value)
On Error GoTo 0
End If
Next rCell2
On Error Resume Next
ReDim Arr2(1 To Col2.Count)

For i2 = LBound(Arr2, 1) To UBound(Arr2, 1)
Arr2(i2) = Col2.Item(i2)
Next i2

ShUnVa.Range("B1").Resize(i2 - 1) = Application.Transpose(Arr2)

ShUnVa.Columns("A:A").Delete Shift:=xlToLeft


End Sub
 
V

Vacation's Over

First Step:
with all your writing and deleting of cells this should help a lot

on error goto subname_error

application.screenupdating=false
Application.Calculation = xlCalculationManual

[your code....]

Application.Calculation = xlCalculationAutomatic
application.screenupdating=true

exit sub

subname_error:

application.calculation=xlmanual
application.screenupdating=true

end sub



Caution: without the subname error feature if you crash the screen will not
update
 
S

Shawn

The code still worked fine. I couldn't tell that it speeded it up any,
however???


--
Thanks
Shawn


Vacation's Over said:
First Step:
with all your writing and deleting of cells this should help a lot

on error goto subname_error

application.screenupdating=false
Application.Calculation = xlCalculationManual

[your code....]

Application.Calculation = xlCalculationAutomatic
application.screenupdating=true

exit sub

subname_error:

application.calculation=xlmanual
application.screenupdating=true

end sub



Caution: without the subname error feature if you crash the screen will not
update


Shawn said:
Below is a code that works great, but is very slow. I made this a three step
code but am fairly certain that a more skilled programmer could fine tune
this into a single step quicker process. Below is the code and I will take
suggestions on new code. Thanks in advance:

Public Sub UniqueValues()

'Searches target range and returns unique values to desired column

Dim Col As Collection
Dim Arr() As Variant
Dim rCell As Range
Dim rng As Range
Dim i As Long
Dim WB As Workbook
Dim sh1 As Worksheet
Dim ShUnVa As Worksheet

Set WB = ActiveWorkbook
Set sh1 = WB.Sheets("Sheet1")
Set ShUnVa = WB.Sheets("UniqueValues")
Set Col = New Collection
Set rng = sh1.Range(sh1.Range("F2"), sh1.Range("GI32").End(xlDown))
Set rng = rng.Resize(, 186)



ShUnVa.Select
ShUnVa.Columns("A:A").Delete Shift:=xlToLeft


For Each rCell In rng.Cells
If Not IsEmpty(rCell.Value) Then
On Error Resume Next
Col.Add rCell.Value, CStr(rCell.Value)
On Error GoTo 0
End If
Next rCell
On Error Resume Next
ReDim Arr(1 To Col.Count)

For i = LBound(Arr, 1) To UBound(Arr, 1)
Arr(i) = Col.Item(i)
Next i

ShUnVa.Range("A1").Resize(i - 1) = Application.Transpose(Arr)

'Sorts the unique values in ascending order

ShUnVa.Columns("A:A").Sort Key1:=Range("A1"), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

'If the first value is zero it deletes it

If ShUnVa.Range("A1").Value = 0 Then ShUnVa.Range("A1").Delete Shift:=xlUp

'Converts the unique values to provider numbers


Dim strConProNum As String
ShUnVa.Range("A1").Select
ShUnVa.Range("A1").Activate
Do Until ActiveCell.Value = ""
strConProNum = ActiveCell.Value

If ActiveCell.Value < 200000 Then
ActiveCell.Value = ActiveCell.Value - 100000
Else
ActiveCell.Value = ActiveCell.Value - 200000
End If
ActiveCell.Offset(1, 0).Select
Loop



'Gets the unique values from the converted data sorts them and moves them to
column A

Dim Col2 As Collection
Dim Arr2() As Variant
Dim rCell2 As Range
Dim rng2 As Range
Dim i2 As Long

Set Col2 = New Collection
Set rng2 = ShUnVa.Range("A:A")


For Each rCell2 In rng2.Cells
If Not IsEmpty(rCell2.Value) Then
On Error Resume Next
Col2.Add rCell2.Value, CStr(rCell2.Value)
On Error GoTo 0
End If
Next rCell2
On Error Resume Next
ReDim Arr2(1 To Col2.Count)

For i2 = LBound(Arr2, 1) To UBound(Arr2, 1)
Arr2(i2) = Col2.Item(i2)
Next i2

ShUnVa.Range("B1").Resize(i2 - 1) = Application.Transpose(Arr2)

ShUnVa.Columns("A:A").Delete Shift:=xlToLeft


End Sub
Click to expand...
Click to expand...
 
J

Jim Cone

Shawn,

Selecting cells is time consuming and usually unnecessary.
The following code excerpt eliminates cell selection...
'------------------------------------------------
'Converts the unique values to provider numbers
Dim rngConProNum As Excel.Range
Set rngConProNum = ShUnVa.Range("A1")
Do Until rngConProNum.Value = ""
If rngConProNum.Value < 200000 Then
rngConProNum.Value = rngConProNum.Value - 100000
Else
rngConProNum.Value = rngConProNum.Value - 200000
End If
Set rngConProNum = rngConProNum(2, 1)
Loop
Set rngConProNum = Nothing
'--------------------------------------------

However, what appears to be the big time consumer is the
code section that follows the above...

Set rng2 = ShUnVa.Range("A:A")
For Each rCell2 In rng2.Cells

Your loop is going thru all 65000 rows in the column.
If you use the code I provided above, then the range object is set
to the last cell in the column (plus one), so the following should work...

Set rng2 = ShUnVa.Range(ShUnVa.Cells(1, 1), rngConProNum)
'----------------------------------

Jim Cone
San Francisco, USA



Below is a code that works great, but is very slow. I made this a three step
code but am fairly certain that a more skilled programmer could fine tune
this into a single step quicker process. Below is the code and I will take
suggestions on new code. Thanks in advance:

Public Sub UniqueValues()
'Searches target range and returns unique values to desired column
Dim Col As Collection
Dim Arr() As Variant
Dim rCell As Range
Dim rng As Range
Dim i As Long
Dim WB As Workbook
Dim sh1 As Worksheet
Dim ShUnVa As Worksheet

Set WB = ActiveWorkbook
Set sh1 = WB.Sheets("Sheet1")
Set ShUnVa = WB.Sheets("UniqueValues")
Set Col = New Collection
Set rng = sh1.Range(sh1.Range("F2"), sh1.Range("GI32").End(xlDown))
Set rng = rng.Resize(, 186)

ShUnVa.Select
ShUnVa.Columns("A:A").Delete Shift:=xlToLeft

For Each rCell In rng.Cells
If Not IsEmpty(rCell.Value) Then
On Error Resume Next
Col.Add rCell.Value, CStr(rCell.Value)
On Error GoTo 0
End If
Next rCell
On Error Resume Next
ReDim Arr(1 To Col.Count)

For i = LBound(Arr, 1) To UBound(Arr, 1)
Arr(i) = Col.Item(i)
Next i

ShUnVa.Range("A1").Resize(i - 1) = Application.Transpose(Arr)

'Sorts the unique values in ascending order
ShUnVa.Columns("A:A").Sort Key1:=Range("A1"), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

'If the first value is zero it deletes it

If ShUnVa.Range("A1").Value = 0 Then ShUnVa.Range("A1").Delete Shift:=xlUp

'Converts the unique values to provider numbers
Dim strConProNum As String
ShUnVa.Range("A1").Select
ShUnVa.Range("A1").Activate
Do Until ActiveCell.Value = ""
strConProNum = ActiveCell.Value

If ActiveCell.Value < 200000 Then
ActiveCell.Value = ActiveCell.Value - 100000
Else
ActiveCell.Value = ActiveCell.Value - 200000
End If
ActiveCell.Offset(1, 0).Select
Loop

'Gets the unique values from the converted data sorts them and moves them to
column A
Dim Col2 As Collection
Dim Arr2() As Variant
Dim rCell2 As Range
Dim rng2 As Range
Dim i2 As Long

Set Col2 = New Collection
Set rng2 = ShUnVa.Range("A:A")

For Each rCell2 In rng2.Cells
If Not IsEmpty(rCell2.Value) Then
On Error Resume Next
Col2.Add rCell2.Value, CStr(rCell2.Value)
On Error GoTo 0
End If
Next rCell2
On Error Resume Next
ReDim Arr2(1 To Col2.Count)

For i2 = LBound(Arr2, 1) To UBound(Arr2, 1)
Arr2(i2) = Col2.Item(i2)
Next i2

ShUnVa.Range("B1").Resize(i2 - 1) = Application.Transpose(Arr2)
ShUnVa.Columns("A:A").Delete Shift:=xlToLeft
End Sub
 
J

Jim Cone

However, the... Set rngConProNum = Nothing
line should be removed.

Jim Cone


Shawn,

Selecting cells is time consuming and usually unnecessary.
The following code excerpt eliminates cell selection...
'------------------------------------------------
'Converts the unique values to provider numbers
Dim rngConProNum As Excel.Range
Set rngConProNum = ShUnVa.Range("A1")
Do Until rngConProNum.Value = ""
If rngConProNum.Value < 200000 Then
rngConProNum.Value = rngConProNum.Value - 100000
Else
rngConProNum.Value = rngConProNum.Value - 200000
End If
Set rngConProNum = rngConProNum(2, 1)
Loop
Set rngConProNum = Nothing
'--------------------------------------------

However, what appears to be the big time consumer is the
code section that follows the above...

Set rng2 = ShUnVa.Range("A:A")
For Each rCell2 In rng2.Cells

Your loop is going thru all 65000 rows in the column.
If you use the code I provided above, then the range object is set
to the last cell in the column (plus one), so the following should work...

Set rng2 = ShUnVa.Range(ShUnVa.Cells(1, 1), rngConProNum)
'----------------------------------

Jim Cone
San Francisco, USA
 
S

Shawn

Here is the code as it stands now. I have implemented everyone's
suggestions. It still runs slow:

Option Explicit
Public Sub UniqueValues()

'Searches target range and returns unique values to desired column



On Error GoTo subname_error

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim Col As Collection
Dim Arr() As Variant
Dim rCell As Range
Dim rng As Range
Dim i As Long
Dim WB As Workbook
Dim sh1 As Worksheet
Dim ShUnVa As Worksheet

Set WB = ActiveWorkbook
Set sh1 = WB.Sheets("Sheet1")
Set ShUnVa = WB.Sheets("UniqueValues")
Set Col = New Collection
Set rng = sh1.Range(sh1.Range("F2"), sh1.Range("GI32").End(xlDown))
Set rng = rng.Resize(, 186)



ShUnVa.Select
ShUnVa.Columns("A:A").Delete Shift:=xlToLeft


For Each rCell In rng.Cells
If Not IsEmpty(rCell.Value) Then
On Error Resume Next
Col.Add rCell.Value, CStr(rCell.Value)
On Error GoTo 0
End If
Next rCell
On Error Resume Next
ReDim Arr(1 To Col.Count)

For i = LBound(Arr, 1) To UBound(Arr, 1)
Arr(i) = Col.Item(i)
Next i

ShUnVa.Range("A1").Resize(i - 1) = Application.Transpose(Arr)

'Sorts the unique values in ascending order

ShUnVa.Columns("A:A").Sort Key1:=Range("A1"), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

'If the first value is zero it deletes it

If ShUnVa.Range("A1").Value = 0 Then ShUnVa.Range("A1").Delete Shift:=xlUp

'Converts the unique values to provider numbers


Dim rngConProNum As Excel.Range
Set rngConProNum = ShUnVa.Range("A1")
Do Until rngConProNum.Value = ""
If rngConProNum.Value < 200000 Then
rngConProNum.Value = rngConProNum.Value - 100000
Else
rngConProNum.Value = rngConProNum.Value - 200000
End If
Set rngConProNum = rngConProNum(2, 1)
Loop


'Gets the unique values from the converted data sorts them and moves them to
column A

Dim Col2 As Collection
Dim Arr2() As Variant
Dim rCell2 As Range
Dim rng2 As Range
Dim i2 As Long

Set Col2 = New Collection
Set rng2 = ShUnVa.Range(ShUnVa.Cells(1, 1), rngConProNum)



For Each rCell2 In rng2.Cells
If Not IsEmpty(rCell2.Value) Then
On Error Resume Next
Col2.Add rCell2.Value, CStr(rCell2.Value)
On Error GoTo 0
End If
Next rCell2
On Error Resume Next
ReDim Arr2(1 To Col2.Count)

For i2 = LBound(Arr2, 1) To UBound(Arr2, 1)
Arr2(i2) = Col2.Item(i2)
Next i2

ShUnVa.Range("B1").Resize(i2 - 1) = Application.Transpose(Arr2)

ShUnVa.Columns("A:A").Delete Shift:=xlToLeft

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

Exit Sub

subname_error:

Application.Calculation = xlManual
Application.ScreenUpdating = True

End Sub
 
D

Dave Peterson

Since you're deleting stuff, maybe it's because xl wants to determine where
those dotted line page break indicators go.

If you do Tools|Options|view tab|uncheck Page Breaks, then run your macro, is it
faster?

If it is, you can turn that setting in code:

ActiveSheet.DisplayPageBreaks = False
or
ShUnVa.displaypagebreaks = false
 
J

Jim Cone

Shawn,

I added code to determine the amount of time each portion
of your code requires. The error handler was also modified.
A Msgbox is inserted immediately after where I believe the problem is.
The time returned is in milliseconds, so divide by 1000 for seconds.

Note: the time function goes above all code at the top of the module.

Jim Cone
San Francisco, USA
'----------------------------------------------

Option Explicit
Private Declare Function timeGetTime Lib "winmm.dll" () As Long '*********

Public Sub UniqueValues2()
'Searches target range and returns unique values to desired column
On Error GoTo subname_error
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim Time1 As Long'*************
Dim Time2 As Long
Dim Time3 As Long
Dim Time4 As Long
Dim Time5 As Long

Dim Col As Collection
Dim Arr() As Variant
Dim rCell As Range
Dim rng As Range
Dim i As Long
Dim WB As Workbook
Dim sh1 As Worksheet
Dim ShUnVa As Worksheet

Set WB = ActiveWorkbook
Set sh1 = WB.Sheets("Sheet1")
Set ShUnVa = WB.Sheets("UniqueValues")
Set Col = New Collection
Set rng = sh1.Range(sh1.Range("F2"), sh1.Range("GI32").End(xlDown))
Set rng = rng.Resize(, 186)

MsgBox rng.Address '**********************

Time1 = timeGetTime '**********************

ShUnVa.Select
ShUnVa.Columns("A:A").Delete Shift:=xlToLeft

For Each rCell In rng.Cells
If Not IsEmpty(rCell.Value) Then
On Error Resume Next
Col.Add rCell.Value, CStr(rCell.Value)
On Error GoTo 0
End If
Next rCell
On Error Resume Next
ReDim Arr(1 To Col.Count)

For i = LBound(Arr, 1) To UBound(Arr, 1)
Arr(i) = Col.Item(i)
Next i

ShUnVa.Range("A1").Resize(i - 1) = Application.Transpose(Arr)

Time2 = timeGetTime '**********************

'Sorts the unique values in ascending order
ShUnVa.Columns("A:A").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

'If the first value is zero it deletes it
If ShUnVa.Range("A1").Value = 0 Then ShUnVa.Range("A1").Delete Shift:=xlUp

Time3 = timeGetTime '**********************

'Converts the unique values to provider numbers
Dim rngConProNum As Excel.Range
Set rngConProNum = ShUnVa.Range("A1")
Do Until rngConProNum.Value = ""
If rngConProNum.Value < 200000 Then
rngConProNum.Value = rngConProNum.Value - 100000
Else
rngConProNum.Value = rngConProNum.Value - 200000
End If
Set rngConProNum = rngConProNum(2, 1)
Loop

Time4 = timeGetTime '**********************

'Gets the unique values from the converted data sorts them and moves them to Column A
Dim Col2 As Collection
Dim Arr2() As Variant
Dim rCell2 As Range
Dim rng2 As Range
Dim i2 As Long

Set Col2 = New Collection
Set rng2 = ShUnVa.Range(ShUnVa.Cells(1, 1), rngConProNum)

For Each rCell2 In rng2.Cells
If Not IsEmpty(rCell2.Value) Then
On Error Resume Next
Col2.Add rCell2.Value, CStr(rCell2.Value)
On Error GoTo 0
End If
Next rCell2
On Error Resume Next
ReDim Arr2(1 To Col2.Count)

For i2 = LBound(Arr2, 1) To UBound(Arr2, 1)
Arr2(i2) = Col2.Item(i2)
Next i2

ShUnVa.Range("B1").Resize(i2 - 1) = Application.Transpose(Arr2)
ShUnVa.Columns("A:A").Delete Shift:=xlToLeft

Time5 = timeGetTime '**********************

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

'************************
MsgBox "First section " & Format$(Time2 - Time1, "#0000") & vbCr & _
"Second section " & Format$(Time3 - Time2, "#0000") & vbCr & _
"Third section " & Format$(Time4 - Time3, "#0000") & vbCr & _
"Fourth section " & Format$(Time5 - Time4, "#0000")
Exit Sub

subname_error:
Beep
Application.Calculation = xlCalculationAutomatic '*******************
Application.ScreenUpdating = True
MsgBox Err.Number & " " & Err.Description
End Sub
'================================


Here is the code as it stands now. I have implemented everyone's
suggestions. It still runs slow:

-snip-
 
S

Shawn

I changed this line of code from :

Set rng = sh1.Range(sh1.Range("F2"), sh1.Range("GI32").End(xlDown))

To:

Set rng = sh1.Range(sh1.Range("F2"), sh1.Range("GI2").End(xlDown)) and
it sped up dramatically.
 

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

Extract Text in braquet and list of terms from 2 Docs 3
use border for IF test 1
Background Color 9
separate data with extra column 1
Using Collection to also capture range adjacent 10
Loop is slow trying array code 17
separate multiline address into separate columns 3
VBA for Dependents shortcut menu 0

Top