Private Sub ListBox1_Click()
Range(ListBox1.Value).Select
End Sub
Private Sub UserForm_Initialize()
ListBox1.ColumnCount = 3
CheckDupplicateCells
End Sub
Private Sub CheckDupplicateCells()
Dim x As Long
Dim LastRow As Long
Dim cl As Range
'---------------------
Dim iPtr As Integer, iPtr1 As Integer
Dim rCur As Range
Const sSeperators As String = "=-*/()&!"
Dim sFormula As String, sChar As String
Dim sCur0 As String, sCur1 As String
Dim saElements() As String
Dim sDups As String
'---------------------
On Error GoTo Errorhandler
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
myrange = ActiveSheet.Range(Cells(1, Selection.Column).Address, Cells(LastRow, Selection.Column).Address).Address
ListBox1.Clear
For Each cl In Range(myrange)
'--
If cl = "" Then GoTo jumpnext
Set rCur = cl.Resize(1, 1)
sFormula = rCur.Formula
sDups = ""
If Len(sFormula) <> 0 Then
ReDim saElements(0 To 0)
For iPtr = 1 To Len(sFormula)
sChar = Mid$(sFormula, iPtr, 1)
If InStr(sSeperators, sChar) <> 0 Then Mid$(sFormula, iPtr, 1) = "+"
Next iPtr
sDups = ""
saElements = Split(sFormula, "+")
For iPtr = 0 To UBound(saElements) - 1
sCur0 = saElements(iPtr)
If sCur0 <> "" Then
For iPtr1 = iPtr + 1 To UBound(saElements)
sCur1 = saElements(iPtr1)
If sCur0 = sCur1 Then
sDups = sDups & sCur1 & vbCrLf
saElements(iPtr) = ""
Exit For
End If
Next iPtr1
End If
Next iPtr
End If
If sDups <> "" Then
ListBox1.AddItem cl.Address
ListBox1.Column(1, ListBox1.ListCount - 1) = cl
ListBox1.Column(2, ListBox1.ListCount - 1) = Left(sDups, Len(sDups) - 2)
End If
'--
jumpnext:
Next
Exit Sub
Errorhandler:
MsgBox "Your sheet is empty"
End Sub