J
Jorgen Bondesen
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
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