How to find multi dependes some cell

[backup69]

Hi

Any ideas on how to check/trace cells for formulas that contain the same cell more than once. And this way all formulas in some column with vba.

For example:
= A1+A2+A3+A2

 

[al_b_cnu]

Hi,

As a 'starter for 10' try this macro:

Sub CheckCells()
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

Set rCur = Selection.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
    MsgBox "Cell " & rCur.Address(False, False) & " has no duplicated elements"
Else
    MsgBox "Cell " & rCur.Address(False, False) & " has the following duplicated elements:" & vbCrLf & sDups
End If
End Sub

You may have to add to the 'sSeperators' constant to suit.

 

[backup69]

Ty for this code and i made fiew changes and here is full version wich search selected column (used range) in active sheet.
I insert all this in to Form with Listbox.

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