On-screen guidance at the moment of need enables you & your employees to focus on the core, you can now boost your adoption rates swiftly and simply with one easy tool.
Become a Premium Member and unlock a new, free course in leading technologies each month.
Add your voice to the tech community where 5M+ people just like you are talking about what matters.
=IF(COUNTIF($A$2:$A$15, "="&MODE($A$2:$A$15))=2,MODE($A$2:$A$15),"")
=IF(COUNTIF($A$2:$A$15, "="&MODE($A$2:$A$15))>2,MODE($A$2:$A$15),"")
Sub compile_duplicates()
For Each c In Range("A2:A" & (Cells.SpecialCells(xlCellTypeLastCell).Row)).Cells
With WorksheetFunction
colnum = .CountIf(Range("A2:A" & (Cells.SpecialCells(xlCellTypeLastCell).Row)), c)
yaxis = .Substitute(Left(Cells(1, colnum + 1).Address, .Find("$", Cells(1, colnum + 1).Address, 2)), "$", "")
xaxis = .CountA(Range(yaxis & ":" & yaxis)) + 1
Range(yaxis & xaxis) = c
End With
Next c
End Sub
For Each c In Src_Range
If WorksheetFunction.CountIf(Src_Range, c) > 1 Then
ReDim Preserve Dup(i)
Dup(i) = c
i = i + 1
End If
Next c
DupArray = Dup
End Function
Function FindDuplicates(Src_Range As Range, Optional Unique_list As Boolean = True, Optional Sort_Dups As Boolean = True)
Dim Dup() As Variant
Dim DupsFound As Boolean
i = 0
'Loop through each cell and if the count is greater than 1 there are duplicates
For Each c In Src_Range
If WorksheetFunction.CountIf(Src_Range, c) > 1 Then
DupsFound = True
ReDim Preserve Dup(i)
Dup(i) = c
i = i + 1
End If
Next c
'If there are no duplicates exit function
If DupsFound = False Then
Exit Function
End If
'Sort array
If Sort_Dups Then
For lLoop = 0 To UBound(Dup)
For lLoop2 = lLoop To UBound(Dup)
If UCase(Dup(lLoop2)) < UCase(Dup(lLoop)) Then
str1 = Dup(lLoop)
str2 = Dup(lLoop2)
Dup(lLoop) = str2
Dup(lLoop2) = str1
End If
Next lLoop2
Next lLoop
End If
'Reduce to unique list
If Unique_list Then
FindDuplicates = UniqueItems(Dup, False)
Else
FindDuplicates = Dup
End If
End Function
Function UniqueItems(ArrayIn, Optional Count As Boolean = True) As Variant
' Accepts an array or range as input
' If Count = True or is missing, the function returns the number of unique elements
' If Count = False, the function returns a variant array of unique elements
Dim Unique() As Variant ' array that holds the unique items
Dim Element As Variant
Dim i As Integer
Dim FoundMatch As Boolean
' Counter for number of unique elements
NumUnique = 0
' Loop thru the input array
For Each Element In ArrayIn
FoundMatch = False
' Has item been added yet?
For i = 1 To NumUnique
If Element = Unique(i - 1) Then
FoundMatch = True
Exit For '(exit loop)
End If
Next i
AddItem:
' If not in list, add the item to unique list
If Not FoundMatch And Not IsEmpty(Element) Then
ReDim Preserve Unique(NumUnique)
Unique(NumUnique) = Element
NumUnique = NumUnique + 1
End If
Next Element
' Assign a value to the function
If Count Then UniqueItems = NumUnique Else UniqueItems = Unique
End Function
Sub Get_Duplicates()
Const Output_Dups As String = "F26"
Const Search_Range As String = "c6:c24"
DupArray = FindDuplicates(Range(Search_Range ))
If IsEmpty(DupArray) Then
Exit Sub
End If
c = Range(Output_Dups ).Column
r = Range(Output_Dups ).Row
'rows
Range(Cells(r, c), Cells(r + UBound(DupArray), c)) = WorksheetFunction.Transpose(DupArray)
'columns
Range(Cells(r, c), Cells(r, c + UBound(DupArray))) = DupArray
End Sub
Sub compile_duplicates()
For Each c In Range("A2:A" & (Cells.SpecialCells(xlCellTypeLastCell).Row)).Cells
With WorksheetFunction
colnum = .CountIf(Range("A2:A" & (Cells.SpecialCells(xlCellTypeLastCell).Row)), c)
yaxis = .Substitute(Left(Cells(1, colnum + 1).Address, .Find("$", Cells(1, colnum + 1).Address, 2)), "$", "")
If .CountIf(Range(yaxis & ":" & yaxis), c) < 1 Then
xaxis = .CountA(Range(yaxis & ":" & yaxis)) + 1
Range(yaxis & xaxis) = c
Else
End If
End With
Next c
End Sub
Sub compile_duplicates()
colStart = "B"
rowStart = 9
cellStart = colStart & rowStart
For Each c In Range(cellStart & ":" & colStart & (Cells.SpecialCells(xlCellTypeLastCell).Row)).Cells
With WorksheetFunction
colnum = .CountIf(Range(cellStart & ":" & colStart & (Cells.SpecialCells(xlCellTypeLastCell).Row)), c)
If colnum > 0 Then
yaxis = .Substitute(Left(Cells(1, colnum + Range(colStart & 1).Column).Address, .Find("$", Cells(1, colnum + 1).Address, 2)), "$", "")
If .CountIf(Range(yaxis & ":" & yaxis), c) < 1 Then
xaxis = .CountA(Range(yaxis & rowStart & ":" & yaxis & Cells.SpecialCells(xlCellTypeLastCell).Row)) + rowStart
Range(yaxis & xaxis) = c
Else
End If
Else
End If
End With
Next c
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
colStart = "B"
rowstart = 9
cellStart = colStart & rowstart
Range(Cells(rowstart, (Range(cellStart).Column + 1)).Address & ":" & Cells.SpecialCells(xlCellTypeLastCell).Address).Clear
For Each c In Range(cellStart & ":" & colStart & (Cells.SpecialCells(xlCellTypeLastCell).Row)).Cells
With WorksheetFunction
colnum = .CountIf(Range(cellStart & ":" & colStart & (Cells.SpecialCells(xlCellTypeLastCell).Row)), c)
If colnum > 0 Then
yaxis = .Substitute(Left(Cells(1, colnum + Range(colStart & 1).Column).Address, .Find("$", Cells(1, colnum + 1).Address, 2)), "$", "")
If .CountIf(Range(yaxis & ":" & yaxis), c) < 1 Then
xaxis = .CountA(Range(yaxis & rowstart & ":" & yaxis & Cells.SpecialCells(xlCellTypeLastCell).Row)) + rowstart
Range(yaxis & xaxis) = c
Else
End If
Else
End If
End With
Next c
End Sub
Solution-27343074.xlsm
If you are experiencing a similar issue, please ask a related question
Join the community of 500,000 technology professionals and ask your questions.