Count two common text strings based on multiple criteria

[thomaslovell]

Hi there,

I have a list of employee names, which are also accompanied by date and location information (see example). I would like to quantify how many relationships exist between the names on the same day/location. In other words, how many times has each employee worked with every other employee. Is there a way to automatically calculate this? Any help would be greatly appreciated!

The list of names/locations/dates looks like this:

Name	Location	Date
John	Sydney	01/03/2021​
Sue	Sydney	01/03/2021​
Greg	Brisbane	01/03/2021​
John	Melbourne	02/03/2021​
Greg	Melbourne	02/03/2021​
Sue	Perth	03/03/2021​
Greg	Melbourne	04/03/2021​
John	Melbourne	04/03/2021​
Sue	Melbourne	04/03/2021​

And then the list of relationships looks like this:

Relationship	Name 1	Name 2	Relations
Relationship 1	John	Sue	1​
Relationship 2	Sue	Greg	1​
Relationship 3	John	Greg	2​

 

[maabadi]

if your Data is in Columns A:C try this Macro. you see results at Columns E:G.

Sub RelationsCount()
 Dim i As Long, j As Long, k As Long, N As Long, Lr As Long, Lr2 As Long, P As Long, R As Long
 Dim d As Object, c As Variant, e As Variant, Mn As Long, Mx As Long, f As Object, g As Variant
 Set d = CreateObject("Scripting.Dictionary")
 Lr = Cells(Rows.Count, 1).End(xlUp).Row
 c = Range("A2:A" & Lr)
 For i = 1 To UBound(c, 1)
  d(c(i, 1)) = 1
 Next i
e = Application.Transpose(d.keys)
Range("E2:G" & Lr).ClearContents
Cells(1, 5).Value = "Name1"
Cells(1, 6).Value = "Name2"
Cells(1, 7).Value = "Relations"
    N = 2
    For i = 1 To UBound(e, 1) - 1
        For j = i + 1 To UBound(e, 1)
            If i <> j Then
                Cells(N, 5) = e(i, 1)
                Cells(N, 6) = e(j, 1)
                N = N + 1
            End If
        Next j
    Next i
Set f = CreateObject("Scripting.Dictionary")
g = Range("B2:B" & Lr)
For i = 1 To UBound(g, 1)
  f(g(i, 1)) = 1
Next i
g = Application.Transpose(f.keys)
Mn = Application.WorksheetFunction.Min(Range("C2:C" & Lr))
Mx = Application.WorksheetFunction.Max(Range("C2:C" & Lr))
Lr2 = Cells(Rows.Count, 5).End(xlUp).Row
For i = Mn To Mx
For j = 1 To UBound(g)
For k = 2 To Lr2
N = Application.WorksheetFunction.CountIfs(Range("A2:A" & Lr), Range("E" & k).Value, Range("B2:B" & Lr), g(j, 1), Range("C2:C" & Lr), i)
P = Application.WorksheetFunction.CountIfs(Range("A2:A" & Lr), Range("F" & k).Value, Range("B2:B" & Lr), g(j, 1), Range("C2:C" & Lr), i)
If N = P And N > 0 Then Cells(k, 7).Value = Cells(k, 7).Value + 1
N = 0
P = 0
Next k
Next j
Next i
End Sub

 

[thomaslovell]

Wow.. thanks very much. I trialled that on my test data set and it worked great.

I tried to adjust based on the columns required for the real data set and I wasn't able to get it working. Do you mind reconfiguring the macro to run with the following references:

The three Data columns are on a sheet named "Data" in columns C (name), K (location) and U (date).

The output columns should go on sheet named "List" in columns E:G

Really appreciate your help!

Thanks

 

[maabadi]

For Your Situation Try This:

Sub RelationsCount()
 Dim i As Long, j As Long, k As Long, N As Long, Lr As Long, Lr2 As Long, P As Long, R As Long
 Dim d As Object, c As Variant, e As Variant, Mn As Long, Mx As Long, f As Object, g As Variant
 With Sheets("Data")
 Set d = CreateObject("Scripting.Dictionary")
 Lr = .Cells(Rows.Count, 3).End(xlUp).Row
 c = Range("C2:C" & Lr)
 For i = 1 To UBound(c, 1)
  d(c(i, 1)) = 1
 Next i
e = Application.Transpose(d.keys)
Sheets("List").Range("E2:G" & Lr).ClearContents
Sheets("List").Cells(1, 5).Value = "Name1"
Sheets("List").Cells(1, 6).Value = "Name2"
Sheets("List").Cells(1, 7).Value = "Relations"
    N = 2
    For i = 1 To UBound(e, 1) - 1
        For j = i + 1 To UBound(e, 1)
            If i <> j Then
                Sheets("List").Cells(N, 5) = e(i, 1)
                Sheets("List").Cells(N, 6) = e(j, 1)
                N = N + 1
            End If
        Next j
    Next i
Set f = CreateObject("Scripting.Dictionary")
g = .Range("K2:K" & Lr)
For i = 1 To UBound(g, 1)
  f(g(i, 1)) = 1
Next i
g = Application.Transpose(f.keys)
Mn = Application.WorksheetFunction.Min(.Range("U2:U" & Lr))
Mx = Application.WorksheetFunction.Max(.Range("U2:U" & Lr))
Lr2 = Sheets("List").Cells(Rows.Count, 5).End(xlUp).Row
For i = Mn To Mx
For j = 1 To UBound(g)
For k = 2 To Lr2
N = Application.WorksheetFunction.CountIfs(.Range("C2:C" & Lr), Sheets("List").Range("E" & k).Value, .Range("K2:K" & Lr), g(j, 1), .Range("U2:U" & Lr), i)
P = Application.WorksheetFunction.CountIfs(.Range("C2:C" & Lr), Sheets("List").Range("F" & k).Value, .Range("K2:K" & Lr), g(j, 1), .Range("U2:U" & Lr), i)
If N = P And N > 0 Then Sheets("List").Cells(k, 7).Value = Sheets("List").Cells(k, 7).Value + 1
N = 0
P = 0
Next k
Next j
Next i
End With
End Sub

 

[thomaslovell]

Thanks very much - it seems to be working up to a point I get this error: Run-time error '6': Overflow.

The output displays the following relationships as per expected (all the way up to 17), but it also shows a blank relationship in the Name2 column for every person (not sure why?) and it also doesn't show the relations count.

Do you know what might be causing these errors?

Name1	Name2	Relations
1​	2​
1​	3​
1​	4​
1​	5​
1​	6​
1​	7​
1​	8​
1​	9​
1​	10​
1​	11​
1​	12​
1​	13​
1​	14​
1​	15​
1​	16​
1​	17​
1​
2​	3​
2​	4​
2​	5​
2​	6​
2​	7​
2​	8​
2​	9​
2​	10​
2​	11​
2​	12​
2​	13​
2​	14​
2​	15​
2​	16​
2​	17​
2​
3​	4​
3​	5​
3​	6​
3​	7​
3​	8​
3​	9​
3​	10​
3​	11​
3​	12​
3​	13​
3​	14​
3​	15​
3​	16​
3​	17​
3​

 

[maabadi]

Search on Internet Error . You can see results because you have data more than you can.