Thread: Slow Code
View Single Post
  #4   Report Post  
Posted to microsoft.public.excel.programming
Jim Cone Jim Cone is offline
external usenet poster
 
Posts: 3,290
Default Slow Code

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



"Shawn" wrote in message

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
--
Thanks
Shawn