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

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

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

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

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

Jim Cone


"Jim Cone" wrote in message ...
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

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



--
Thanks
Shawn


"Jim Cone" wrote:

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

Jim Cone


"Jim Cone" wrote in message ...
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

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




Shawn wrote:

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

--
Thanks
Shawn

"Jim Cone" wrote:

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

Jim Cone


"Jim Cone" wrote in message ...
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



--

Dave Peterson

I added the code you suggested. Still slow.
--
Thanks
Shawn


"Dave Peterson" wrote:

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




Shawn wrote:

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

--
Thanks
Shawn

"Jim Cone" wrote:

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

Jim Cone


"Jim Cone" wrote in message ...
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



--

Dave Peterson