Wow, that's awesome Mick! After a couple hours staring at your code and looking up most of it in reference sheets. Breaking your code several times during trial and error because of tweaking it now works! 
I ended up using the first macro and tweaked it. I also changes my requirements a little.
This is the code that I am using now:
Public Sub MG15May14()
Dim Rng As Range
Dim Dn As Range
Dim Twn As String
Dim Frng As Range
Dim LRng As Range
Dim Q
Set Rng = Range(Range("C1"), Range("C" & Rows.Count).End(xlUp))
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In Rng
If Not Dn.Offset(, 1) = vbNullString And Not Dn.Offset(, 2) = vbNullString Then
Twn = Dn & Dn.Offset(, 1) & Dn.Offset(, 2) & Dn.Offset(, 4) & Dn.Offset(, 10) & Dn.Offset(, 11) & Dn.Offset(, 12) & Dn.Offset(, 13) _
& Dn.Offset(, 15) & Dn.Offset(, 16) & Dn.Offset(, 17)
If Not .exists(Twn) Then
.Add Twn, Array(Dn, Frng, LRng)
Else
Q = .Item(Twn)
If Q(2) Is Nothing Then
Set Q(2) = Dn
Else
If Q(1) Is Nothing Then
Set Q(1) = Q(2)
Else
Set Q(1) = Union(Q(1), Q(2))
End If
Set Q(2) = Dn
End If
Q(0).EntireRow.Borders.ColorIndex = 5
Q(0).EntireRow.Borders.Weight = xlThick
Q(2).EntireRow.Borders.ColorIndex = 3
Q(2).EntireRow.Borders.Weight = xlThick
'If Not Q(1) Is Nothing Then Q(1).EntireRow.Interior.ColorIndex = 4 'xlNone
' .Item(Twn) = Q
End If
End If
Next
End With
'MsgBox "I just ran"
End Sub
And it's awesome
I'm going to change the title of this post to 'solved'. Thank you so much Mick! I am not only happy that it works, but also that I learned a lot in the process
.
Bookmarks