Want to avoid the missteps to gaining all the benefits of the cloud? Learn more about the different assessment options from our Cloud Advisory team.
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.