How to maintain size of array: UniqRow

  • Thread starter Jorgen Bondesen
  • Start date

Jorgen Bondesen


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


Dim count As Long
count = count + 1

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

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

'// Clear error

'// trying to reset
Set UniqRow2 = Nothing

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

On Error GoTo 0
Next cell

Application.Calculation = xlCalc

End If


Application.Calculation = xlCalc

Set RRange = Nothing
End Sub


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.

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

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".


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

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

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question