Remove Column Duplicates
The issue you (we) are encountering is probably due to the first column containing mixed data: numbers and strings. Manually you could do something like adding another column and using the formula =TEXT(A1,"#") and then copy it back and do the remove duplicates. I tried for a while to do it in VBA using RemoveDuplicates, but couldn't get it to work. An idea might be to write the formula to another worksheet (workbook) and then process it there and then copy it back... it all becomes rather messy.
So I rather created a different solution consisting of multiple procedures that do cover some ridiculous scenarios but might come in handy in some other projects of yours.
The main procedure is removeColumnDupes which you call from the Worksheet Change event code or from the two other preceding small procedures. It will call the remaining procedures when necessary. Copy all of it to the appropriate modules.
In the worksheet, nothing will happen until you change a value in column A. If you don't want to change anything just select one of the cells and click on the Formula Bar and press Enter. This is also considered a change. Now the duplicates have been removed and you cannot enter a duplicate in column A.
If you don't want to use the event, you can uncomment the Exit Sub at the beginning of it or uncomment or delete it. Then you can use removeColumnDupesTEST. Note that if you haven't disabled the event solution, this will cause the removeDupes procedure to always run three times: once for itself (...TEST), once for writing the data, and once for clearing the contents.
The removeColumnDupesSelection procedure may come in handy when you want to select any cell and remove the duplicates from it to the bottom-most unoccupied cell.
Note when using this event, you have to be careful that it won't get retriggered again and again and 'crash' Excel. This is done by disabling events. See this in the event procedure.
Sheet Module e.g. Sheet1 (the name not in parentheses in VBE Project Explorer)
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
'Exit Sub ' Uncomment if you don't want to run it.
Const ProcName As String = "Worksheet_Change"
On Error GoTo clearError
Const FirstCell As String = "A2"
Dim cel As Range: Set cel = Range(FirstCell)
If Not Intersect(Columns(cel.Column), Target) Is Nothing Then
Application.ScreenUpdating = False
Application.EnableEvents = False
removeColumnDupes cel
Application.EnableEvents = True
End If
ProcExit:
Exit Sub
clearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
If Not Application.EnableEvents Then
Application.EnableEvents = True
End If
Resume ProcExit
End Sub
Standard Module e.g. Module1
Option Explicit
' Select the first cell in a column in which you want to remove dupes and run.
Sub removeColumnDupesSelection()
If TypeName(Selection) = "Range" Then
removeColumnDupes Selection.Cells(1)
End If
End Sub
' Run in a column.
Sub removeColumnDupesTEST()
Const FirstCellAddress As String = "A2"
removeColumnDupes Range(FirstCellAddress)
End Sub
' Main Procedure
Sub removeColumnDupes( _
FirstCellRange As Range, _
Optional ByVal clearContentsBelow As Boolean = True)
Dim rg As Range: Set rg = refColumn(FirstCellRange)
Dim Data As Variant: Data = getColumn(rg)
Data = getUniqueData(Data)
writeColumnData FirstCellRange, Data, clearContentsBelow
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: In a worksheet column, creates a reference to the range
' from a given cell 'FirstCellRange' to the bottom-most
' unoccupied cell i.e. all cells below the latter are empty
' (="", ="'"... are not included).
' If `NonBlankInsteadOfNonEmpty` is 'True', the bottom-most cell,
' whose contents have a length of greater than 0, is condsidered
' as the bottom-most unoccupied cell i.e. all cells below
' the latter are blank ('Empty', ="", ="'"...).
' Remarks: Although 'FirstCellRange' can be a range of any size,
' only its first cell will be considered.
' Limitations: If the worksheet contains filtered rows, both options may fail.
' If it contains hidden rows, then only 'NonBlank' may fail.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function refColumn( _
FirstCellRange As Range, _
Optional ByVal NonBlankInsteadOfNonEmpty As Boolean = False) _
As Range
Const ProcName As String = "refColumn"
On Error GoTo clearError
If Not FirstCellRange Is Nothing Then
With FirstCellRange.Cells(1)
Dim cLookIn As XlFindLookIn
If NonBlankInsteadOfNonEmpty Then
cLookIn = xlValues
Else
cLookIn = xlFormulas
End If
Dim cel As Range
Set cel = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , cLookIn, , , xlPrevious)
If Not cel Is Nothing Then
Set refColumn = .Resize(cel.Row - .Row + 1)
End If
End With
End If
ProcExit:
Exit Function
clearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Writes the values from a column ('ColumnNumber')
' of a range ('rg') to a 2D one-based array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function getColumn( _
rg As Range, _
Optional ByVal ColumnNumber As Long = 1, _
Optional ByVal doTranspose As Boolean = False) _
As Variant
Const ProcName As String = "getColumn"
On Error GoTo clearError
If Not rg Is Nothing Then
If ColumnNumber > 0 And ColumnNumber <= rg.Columns.Count Then
With rg.Columns(ColumnNumber)
Dim rCount As Long: rCount = rg.Rows.Count
Dim Result As Variant
If rCount > 1 Then
If doTranspose Then
Dim Data As Variant: Data = .Value
ReDim Result(1 To 1, 1 To rCount)
Dim r As Long
For r = 1 To rCount
Result(1, r) = Data(r, 1)
Next r
getColumn = Result
Else
getColumn = .Value
End If
Else
ReDim Result(1 To 1, 1 To 1): Result(1, 1) = .Value
getColumn = Result
End If
End With
End If
End If
ProcExit:
Exit Function
clearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Writes the unique values from a 2D array
' to a 2D one-based array, excluding error and blank values.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function getUniqueData( _
Data As Variant, _
Optional ByVal Order As XlSearchOrder = xlByRows, _
Optional ByVal Direction As XlSearchDirection = xlNext, _
Optional ByVal CompareMethod As VbCompareMethod = vbTextCompare, _
Optional ByVal doTranspose As Boolean = False) _
As Variant
Const ProcName As String = "getUniqueData"
On Error GoTo clearError
If Not IsEmpty(Data) Then
Dim Limits(1 To 4) As Long
Limits(1) = LBound(Data, 1): Limits(2) = UBound(Data, 1)
Limits(3) = LBound(Data, 2): Limits(4) = UBound(Data, 2)
Dim r1 As Long: r1 = Limits(Direction + 2 * (Order - 1))
Dim r2 As Long: r2 = Limits(3 - Direction + 2 * (Order - 1))
Dim c1 As Long: c1 = Limits(Direction + 2 * (2 - Order))
Dim c2 As Long: c2 = Limits(3 - Direction + 2 * (2 - Order))
Dim st1 As Long: st1 = 3 - 2 * Direction
Dim st2 As Long: st2 = 3 - 2 * Direction
Dim d1 As Long: d1 = 2 - Direction ' 2-1=1,2-2=0
Dim d2 As Long: d2 = Direction - 1 ' 1-1=0,2-1=1
Dim Key As Variant
Dim r As Long
Dim c As Long
With CreateObject("Scripting.Dictionary")
.CompareMode = CompareMethod
For r = r1 To r2 Step st1
For c = c1 To c2 Step st2
Key = Data(r * d1 + c * d2, r * d2 + c * d1)
If Not IsError(Key) Then
If Len(Key) > 0 Then
.Item(Key) = Empty
End If
End If
Next c
Next r
Dim uCount As Long: uCount = .Count
If uCount > 0 Then
Dim Result As Variant
If doTranspose Then
ReDim Result(1 To 1, 1 To uCount)
c = 0
For Each Key In .Keys
c = c + 1
Result(1, c) = Key
Next Key
Else
ReDim Result(1 To uCount, 1 To 1)
r = 0
For Each Key In .Keys
r = r + 1
Result(r, 1) = Key
Next Key
End If
getUniqueData = Result
End If
End With
End If
ProcExit:
Exit Function
clearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Writes the values of the first column of a given 2D one-based
' array to a worksheet column starting from
' a given cell 'FirstCellRange'.
' Optionally (by default) it previously clears the contents
' below the resulting data.
' Remarks: Although 'Firs
与恶龙缠斗过久,自身亦成为恶龙；凝视深渊过久,深渊将回以凝视…
