Drawing lines

Ok this one works for me but seems to make everything an associate of the name in A1 regardless of if an association has been created or not

Maybe me trying to explain myself poorly as usual

The names in row A are just a list of names - if they have an associate then that associate is put in column b,c,d and so on

So the name in A1 may not be associated to the name in A2 and so on unless thier name appears in column b,c,d etc

I also noted that some of the associations created are incorrect, is this due to them all going through the name in A1?

Sorry if i havnt been clear as to what i need

If you want to skip Col A then change this line.

Code:

---

For j = 1 To LastCol

---

To

Code:

---

For j = 2 To LastCol

---

Looking good Jake and now im starting to understand how its working it looks like it will do what i want, just one other thing, is it possible to remove the two way links as I will for example have the association in two records and only need the one link, not one each way?

Try this.

Code:

---

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
Set Col = New Collection
    With Sheets("Main")
        LastCol = .Range("IV1").End(xlToLeft).Column
        For j = 2 To LastCol
            LastRow = .Range(Cells(65536, j).Address).End(xlUp).Row
            Set Cel1 = Cells.Find(What:=.Range(Cells(1, j).Address).Text, _
            LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
            If Not Cel1 Is Nothing Then
                For i = 2 To LastRow
                    If Application.WorksheetFunction.CountIf( _
                        .Range(Cells(2, j).Address & ":" & 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).Value = Cel1.Text & "@@@" & Cel2.Text Or _
                                    Col(k).Value = 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, j + 2
                                End If
                            End If
                        End If
                    End If
                Next i
            End If
        Next j
    End With
End Sub

---

Also note that some of the names have trailing spaces. For example you have Fred typed in as "Fred " in Column A.

Get an error object required at the following point

Code:

---

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
Set Col = New Collection
    With Sheets("Main")
        LastCol = .Range("IV1").End(xlToLeft).Column
        For j = 2 To LastCol
            LastRow = .Range(Cells(65536, j).Address).End(xlUp).Row
            Set Cel1 = Cells.Find(What:=.Range(Cells(1, j).Address).Text, _
            LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
            If Not Cel1 Is Nothing Then
                For i = 2 To LastRow
                    If Application.WorksheetFunction.CountIf( _
                    .Range(Cells(2, j).Address & ":" & 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).Value = Cel1.Text & "@@@" & Cel2.Text Or _'<<<error here
                                Col(k).Value = 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, j + 2
                        End If
                    End If
                End If
            End If
        Next i
    End If
Next j
End With
End Sub

---

Ok, there was a typo in the last bit of code. Try this.

Code:

---

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
Set Col = New Collection
    With Sheets("Main")
        LastCol = .Range("IV1").End(xlToLeft).Column
        For j = 2 To LastCol
            LastRow = .Range(Cells(65536, j).Address).End(xlUp).Row
            Set Cel1 = Cells.Find(What:=.Range(Cells(1, j).Address).Text, _
            LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
            If Not Cel1 Is Nothing Then
                For i = 2 To LastRow
                    If Application.WorksheetFunction.CountIf( _
                    .Range(Cells(2, j).Address & ":" & 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, j + 2
                        End If
                    End If
                        End If
                    End If
                Next i
            End If
        Next j
    End With
End Sub

---

Thanks Jake, this does work spot on, just one last question and then please mark this as solved, how do i swap it around to make associates rows instead of columns?

Swap the two loops and it should work, though there may need to be some tweaking.

Code:

---

For j = 2 To LastCol
For i = 2 To LastRow

---

If it doesn't work post another attachment with the new data layout.

Sorry Jake tried that but didnt work


On the main page of the attached i ve put a few comments detailing what im after

Thanks again

This should do what you want.

Code:

---

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

---

Jake you make my life so much easier

I owe you my thanks (Again!!)

You're Welcome :beerchug:

And thanks to Arron for the function that creates the shapes.