How to maintain size of array: UniqRow
 

Hi NG

I need help.
I can not maintain (lock) the array: UniqRow
Look below at my comment (remarks) in the macro, please.


Option Explicit


'----------------------------------------------------------
' Procedure : AvoidNowithX
' Date : 20110802
' Author : Joergen Bondesen
' Modifyed by :
' Purpose : Avoid duplicats in Column A (row) if X in
' Column C. Copy none x number to Column D
' Note : X = x.
' Column A = Number
' Columm B = Not in use
' Column C = "X"
' Column D = Alle Numbers without X
'----------------------------------------------------------
'
Sub AvoidNowithX()

Application.ScreenUpdating = False

'// Getting Range
Dim RRange As Range
Set RRange = Range("A2:A" & Cells(Rows.count, 1).End(xlUp).Row)

'// Finding "X" numbers
Dim cell As Range
For Each cell In RRange
On Error Resume Next
If UCase(cell.Offset(0, 2).Value) = "X" Then
Dim UniqRow As New Collection
UniqRow.Add Item:=cell, Key:=CStr(cell)
Application.StatusBar = cell.Row & " Uniq"
End If
On Error GoTo 0
Next cell

'// Trying to "lock" UniqRow, but it do not work
Set UniqRow = UniqRow

Dim Uniq As Double
Uniq = UniqRow.count

If Uniq 0 Then
'// Avoid calculation
Dim xlCalc As XlCalculation
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack

Dim UniqRow2 As New Collection

For Each cell In RRange

'// Just testing
Uniq = UniqRow.count

'// Just testing
Dim Uniq2 As Double
Uniq2 = UniqRow2.count

'//
On Error Resume Next
'// If number can be added, it goes to column D
UniqRow2.Add Item:=cell, Key:=CStr(cell)
If Err.Number < 0 Then

Else

Dim count As Long
count = count + 1

Cells(count + 1, 4).Value = cell.Value

Application.StatusBar = cell.Row & " Next"
End If

'// Clear error
Err.Clear

'// trying to reset
Set UniqRow2 = Nothing

'// Get the original array, but it is changed when I add a value.
PROBLEM
Set UniqRow2 = UniqRow

On Error GoTo 0
Next cell

Application.Calculation = xlCalc

End If

CalcBack:

Application.Calculation = xlCalc

Set RRange = Nothing
End Sub



--
Best regards
Jorgen Bondesen

How to maintain size of array: UniqRow
 

Hi NG

Sorry, I found a solution.

UniqRow.Remove (Uniq + 1)

--
Best regards
Jorgen Bondesen


"Jorgen Bondesen" skrev i en meddelelse
...
Hi NG

I need help.
I can not maintain (lock) the array: UniqRow
Look below at my comment (remarks) in the macro, please.


Option Explicit


'----------------------------------------------------------
' Procedure : AvoidNowithX
' Date : 20110802
' Author : Joergen Bondesen
' Modifyed by :
' Purpose : Avoid duplicats in Column A (row) if X in
' Column C. Copy none x number to Column D
' Note : X = x.
' Column A = Number
' Columm B = Not in use
' Column C = "X"
' Column D = Alle Numbers without X
'----------------------------------------------------------
'
Sub AvoidNowithX()

Application.ScreenUpdating = False

'// Getting Range
Dim RRange As Range
Set RRange = Range("A2:A" & Cells(Rows.count, 1).End(xlUp).Row)

'// Finding "X" numbers
Dim cell As Range
For Each cell In RRange
On Error Resume Next
If UCase(cell.Offset(0, 2).Value) = "X" Then
Dim UniqRow As New Collection
UniqRow.Add Item:=cell, Key:=CStr(cell)
Application.StatusBar = cell.Row & " Uniq"
End If
On Error GoTo 0
Next cell

'// Trying to "lock" UniqRow, but it do not work
Set UniqRow = UniqRow

Dim Uniq As Double
Uniq = UniqRow.count

If Uniq 0 Then
'// Avoid calculation
Dim xlCalc As XlCalculation
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack

Dim UniqRow2 As New Collection

For Each cell In RRange

'// Just testing
Uniq = UniqRow.count

'// Just testing
Dim Uniq2 As Double
Uniq2 = UniqRow2.count

'//
On Error Resume Next
'// If number can be added, it goes to column D
UniqRow2.Add Item:=cell, Key:=CStr(cell)
If Err.Number < 0 Then

Else

Dim count As Long
count = count + 1

Cells(count + 1, 4).Value = cell.Value

Application.StatusBar = cell.Row & " Next"
End If

'// Clear error
Err.Clear

'// trying to reset
Set UniqRow2 = Nothing

'// Get the original array, but it is changed when I add a value.
PROBLEM
Set UniqRow2 = UniqRow

On Error GoTo 0
Next cell

Application.Calculation = xlCalc

End If

CalcBack:

Application.Calculation = xlCalc

Set RRange = Nothing
End Sub



--
Best regards
Jorgen Bondesen

How to maintain size of array: UniqRow
 

A couple of issues jump out at me here.

In your For...Each...Next loop:
You recreate a new collection named "UniqRow".

A collection is not an array.

You read each cell of the worksheet. This is rather slow.

Suggestion:
Dump the entire sheet into an array and work the array to remove
duplicate rows.

Example:
Dim vData As Variant, vaNums()
Dim i As Long, k As Long
vData = ActiveSheet.UsedRange
For i = LBound(vData) To UBound(vData)
If vData(i, 3) = "X" Then
ReDim Preserve vaNums(k)
vaNums(k) = vData(i, 1): k = k + 1
End If
Next 'i

Now, vaNums is na array that contains a list of the numbers in ColA
where ColC contained "X".

--
Garry

Free usenet access at http://www.eternal-september.org
ClassicVB Users Regroup! comp.lang.basic.visual.misc

How to maintain size of array: UniqRow
 

I forgot to mention that your code neglects to reset the StatusBar to
ready status.

...
Set RRange = Nothing: Application.StatusBar = ""
End Sub

--
Garry

Free usenet access at http://www.eternal-september.org
ClassicVB Users Regroup! comp.lang.basic.visual.misc

How to maintain size of array: UniqRow
 

Hi Garry

Thanks for your reply. I will try it.

--
Best regards
Jorgen Bondesen

"GS" skrev i en meddelelse
...
I forgot to mention that your code neglects to reset the StatusBar to ready
status.

...
Set RRange = Nothing: Application.StatusBar = ""
End Sub

--
Garry

Free usenet access at http://www.eternal-september.org
ClassicVB Users Regroup! comp.lang.basic.visual.misc