This should do what you want.
Sub MyTest()
Dim Cel1 As Range
Dim Cel2 As Range
Dim i As Long
Dim j As Long
Dim k As Long
Dim Col As Collection
Dim LastCol As Long
Dim LastRow As Long
Dim Skip As Boolean
For Each sh In ActiveSheet.Shapes
If Left(sh.Name, 1) = Chr(164) Then sh.Delete
Next sh
Set Col = New Collection
With Sheets("Main")
LastRow = .Range("A65536").End(xlUp).Row
For i = 1 To LastRow
LastCol = .Range("IV" & i).End(xlToLeft).Column
Set Cel1 = Cells.Find(What:=.Range(Cells(i, 1).Address).Text, _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not Cel1 Is Nothing Then
For j = 2 To LastCol
If Application.WorksheetFunction.CountIf( _
.Range("A" & i & ":" & Cells(i, j).Address), _
.Range(Cells(i, j).Address).Text) = 1 _
And .Range(Cells(i, j).Address).Text <> "" Then
Set Cel2 = Cells.Find(What:=.Range(Cells(i, j).Address).Text, _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not Cel2 Is Nothing Then
If Cel1.Address <> Cel2.Address Then
Skip = False
For k = 1 To Col.Count
If Col(k) = Cel1.Text & "@@@" & Cel2.Text Or _
Col(k) = Cel2.Text & "@@@" & Cel1.Text Then
Skip = True
Exit For
End If
Next k
If Skip = False Then
Col.Add Cel1.Text & "@@@" & Cel2.Text
MyCon Cel1, Cel2, i + 2
End If
End If
End If
End If
Next j
End If
Next i
End With
End Sub