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


--
Thanks
Shawn


"Vacation's Over" wrote:

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" wrote:

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