Find value intersections in multiple columns

Question

I am well out of my depth here: Can this be done? And if so, what methods should I consider? I periodically receive a spreadsheet that contains a variable number of sheets. Each sheet has the same header row, but different values in the rows beneath. In one column is an identifying number that indicates a unique user, and I need to determine if there is an intersection between any of the Identifier columns on those worksheets. Here is a simplified example, in which the first and third worksheet have an intersection of abc789 but there is no intersecting value in Worksheet 2. I want to know when there is an intersection, and between which worksheets: ``` Worksheet 1: ID_Number • abc123 • abc456 • abc789 Worksheet 2: ID_Number • abc234 • abc345 • abc912 Worksheet 3: ID_Number • abc789 • abc567 • abc678 ``` If it can be done, I'm suspicious of another problem: doing it in a way that works for 3 sheets today and 10 sheets tomorrow! To answer that question I tried setting variables for an…

Accepted Answer

This will output a list of all ID's that were found more than once and what sheets they were found in on a summary sheet:

```
Sub tgr()

Const strIDCol As String = "A"
    Const lHeaderRow As Long = 1

Dim cllIDs As Collection
    Dim ws As Worksheet
    Dim IDCell As Range
    Dim arrUnqIDs(1 To 65000) As Variant
    Dim arrMatches(1 To 65000) As String
    Dim ResultIndex As Long
    Dim lUnqIDCount As Long

Set cllIDs = New Collection

For Each ws In ActiveWorkbook.Sheets
        With Range(ws.Cells(lHeaderRow + 1, strIDCol), ws.Cells(ws.Rows.Count, strIDCol).End(xlUp))
            If .Row > lHeaderRow Then
                For Each IDCell In .Cells
                    On Error Resume Next
                    cllIDs.Add IDCell.Text, LCase(IDCell.Text)
                    On Error GoTo 0
                    If cllIDs.Count > lUnqIDCount Then
                        lUnqIDCount = cllIDs.Count
                        arrUnqIDs(lUnqIDCount) = IDCell.Text
                        arrMatches(lUnqIDCount) = ws.Name
                    Else
                        ResultIndex = WorksheetFunction.Match(IDCell.Text, arrUnqIDs, 0)
                        arrMatches(ResultIndex) = arrMatches(ResultIndex) & "|" & ws.Name
                    End If
                Next IDCell
            End If
        End With
    Next ws

If lUnqIDCount > 0 Then
        With Sheets.Add(Before:=ActiveWorkbook.Sheets(1))
            With .Range("A1:B1")
                .Value = Array("Intersecting ID's", "Intersected in Sheets...")
                .Font.Bold = True
            End With
            .Range("A2").Resize(lUnqIDCount).Value = Application.Transpose(arrUnqIDs)
            .Range("B2").Resize(lUnqIDCount).Value = Application.Transpose(arrMatches)
            .UsedRange.AutoFilter 2, "<>*|*"
            .UsedRange.Offset(1).EntireRow.Delete
            .UsedRange.AutoFilter
            .Range("A1").CurrentRegion.EntireColumn.AutoFit
        End With
    End If

Set cllIDs = Nothing
    Set ws = Nothing
    Set IDCell = Nothing
    Erase arrUnqIDs
    Erase arrMatches

End Sub
```

Find value intersections in multiple columns

Solution

Problem