I need to hide duplicate cells in a range.
with using AdvancedFilter
, it hides the duplicate cells But It also prevents me from doing a subsequent normal Filter.
I have used the below working code by Mr @FaneDure, but it depends on a helper column.
I seek to the same result If it could be achieved without using a helper column.
Is it possible to put the address of the unique cells in an array and then use that array as the criteria of AutoFilter?
kindly note that after duplicate cells is hidden, I will manually do a subsequent normal Filter(s).
In advance, great thanks for you time to help.
Sub Hide_visible_duplicate_cells_(procRng As Range)
Dim arng As Range, C As Range, dict As New Scripting.Dictionary
Dim arrMark, colMark As Range, lastC As Long, sh As Worksheet, lastR As Long, i As Long
Const markName As String = "Marker_column"
Set arng = procRng.SpecialCells(xlCellTypeVisible)
If arng Is Nothing Then MsgBox "Not a valid Range": Exit Sub
Set sh = procRng.Parent 'the sheet where the range belongs to
lastR = sh.UsedRange.rows(sh.UsedRange.rows.count).row 'last row OF THE SHEET
ReDim arrMark(1 To lastR, 1 To 1) 'redim the markers array
'determinte the column where the marker to be placed (or it already exists):
Set colMark = sh.rows(procRng.cells(1).row).Find(What:=markName, LookIn:=xlValues, LookAt:=xlWhole)
If Not colMark Is Nothing Then
lastC = colMark.column 'for the case when the marker column exists
Else
lastC = sh.cells(procRng.cells(1).row, sh.Columns.count).End(xlToLeft).column + 1 'next empty column if marker column does not exist
'to correct the last column number, IF LAST COLUMN IS HIDDEN (it MUST HAVE A HEADER):
If sh.cells(procRng.cells(1).row, lastC).Value <> "" Then lastC = lastC + 1
End If
For Each C In arng.cells
If Not dict.Exists(C.Value) Then
If i > 0 Then 'to skip the first cell, which should be on the headers row
dict.Add C.Value, vbNullString 'Keep the first occurrence
arrMark(C.row - procRng.cells(1).row, 1) = "True" 'place the marker for the first occurrence
End If
If C.Value <> "" Then i = i + 1 'for the case of empty cells above the header...
End If
Next C
'place the marker column header, if not already existing:
If colMark Is Nothing Then sh.cells(procRng.cells(1).row, lastC).Value = markName 'place the marker column name, IF NOT EXISTS
If sh.AutoFilterMode Then sh.AutoFilterMode = False 'eliminate the filter, if any
'drop the markers array content:
sh.cells(procRng.cells(1).row + 1, lastC).Resize(UBound(arrMark), 1).Value2 = arrMark
'filter by the marker column
sh.Range(sh.cells(procRng.cells(1).row, 1), sh.cells(sh.UsedRange.rows.count, lastC)).AutoFilter lastC, "True"
End Sub
Please, try the next code. It concatenate the first found cells content and add a string not very probable to be found in another cell. Then place them as item in the used dictionary. In fact, look at it and its comments:
Sub Hide_visible_duplicate_c(procRng As Range)
Dim arng As Range, C As Range, dict As New Scripting.Dictionary
Const strStr As String = "###$$" 'something unusual, to not be found in the other cells content
Set arng = procRng.Offset(1).Resize(procRng.rows.count - 1).SpecialCells(xlCellTypeVisible) 'eliminating the header
If arng Is Nothing Then MsgBox "Not a valid Range": Exit Sub
Application.Calculation = xlCalculationManual: Application.ScreenUpdating = False
For Each C In arng.cells
If Not dict.Exists(C.Value) Then
dict.Add C.Value, C.Value & strStr 'Keep the first occurrence but miodified string item
C.Value = dict(C.Value) 'modify the first occurence cell content
End If
Next C
procRng.CurrentRegion.AutoFilter procRng.column, dict.Items, xlFilterValues 'filter by the modified cells
procRng.Replace strStr, "" 'replace the added unusual string
Application.Calculation = xlCalculationAutomatic: Application.ScreenUpdating = True
MsgBox "Ready...", vbInformation, "Job done"
End Sub
It can be tested in in the next way:
Sub TestHide_visible_duplicate_cells()
Dim sh As Worksheet, lastR As Long
Const filtCol As Long = 2 'change here according to the need
Const headerRow As Long = 2 'change it if necessary
Set sh = ActiveSheet: lastR = sh.cells(sh.rows.count, filtCol).End(xlUp).row
If Not sh.FilterMode Then MsgBox "This code needs a filtered range to be processed!", vbInformation, "End": Exit Sub
Hide_visible_duplicate_c sh.Range(sh.cells(headerRow, filtCol), sh.cells(lastR, filtCol)) 'send the filtered column as argument
End Sub