Slow Code
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
|