Compare two strings and return matched values?

Question

I'm looking to compare two strings within two adjacent cells. All values separated by a comma. Returning the matched values separated by a comma.

Values are sometimes repeated more than once, and can be in different parts of the string. The largest string length in my list is 6264.

e.g.

Cell X2 = 219728401, 219728401, 219729021, 219734381, 219735301, 219739921

Cell Y2 = 229184121, 219728401, 219729021, 219734333, 216235302, 219735301

Result/Output = 219728401, 219729021, 219735301

The cells I would like to apply this to is not limited to only X2 and Y2, it would be columns X and Y, with output into column Z (or a column I can specify).

I appreciate any help with this, as my VBA knowledge is limited in Excel.

Thank you.

Answer 1

Here's another version that uses a Dictionary object to assess matches.

It also uses arrays to speed up the processing -- useful with large data sets.

Be sure to set a reference as noted in the comments of the code, but if you are going to be distributing this code, you may prefer to use late-binding.

One assumption is that all of your values are numeric. If some include text, you may (or may not) want to change the dictionary comparemode to Text.

Option Explicit
'Set reference to Microsoft Scripting Runtime

Sub MatchUp()
    Dim WS As Worksheet, R As Range
    Dim V, W, X, Y, Z
    Dim D As Dictionary
    Dim I As Long

Set WS = Worksheets("sheet1") 'Change to your desired worksheet
With WS
    'Change `A` to `X` for your stated setup
    Set R = .Range(.Cells(1, "A"), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=3)

    'Read range into variant array
    V = R
End With

For I = 2 To UBound(V, 1)
    W = Split(V(I, 1), ",")
    X = Split(V(I, 2), ",")
    V(I, 3) = ""

    'Test and populate third column (in array) if there are matches
    'Will also eliminate any duplicate codes within the data columns
    Set D = New Dictionary
        For Each Y In W
            Y = Trim(Y) 'could be omitted if no leading/trailing spaces
            If Not D.Exists(Y) Then D.Add Y, Y
        Next Y
        For Each Z In X
            Z = Trim(Z)
            If D.Exists(Z) Then V(I, 3) = V(I, 3) & ", " & Z
        Next Z
    V(I, 3) = Mid(V(I, 3), 3)
Next I

R.EntireColumn.Clear
R.EntireColumn.NumberFormat = "@"
R.Value = V 'write the results back to the worksheet, including column 3
R.EntireColumn.AutoFit
End Sub

Answer 2

If you now select a range of rows and run the macro - it will fill in Z column for each row selected based on X and Y column inputs.

Sub Macro1()
  ' https://stackoverflow.com/questions/54732564/compare-two-strings-and-return-matched-values
  Dim XString       As String
  Dim YString       As String
  Dim XArray()      As String
  Dim YArray()      As String
  Dim xe            As Variant
  Dim ye            As Variant
  Dim res           As Variant
  Dim ZString       As String
  Dim resCollection As New Collection
  Dim XColumnNumber As Long
  Dim YColumnNumber As Long
  Dim ZColumnNumber As Long
  Dim found         As Boolean
  XColumnNumber = Range("X1").Column
  YColumnNumber = Range("Y1").Column ' Could have done XColumn + 1 ! But if you want F and H it will work too now.
  ZColumnNumber = Range("Z1").Column ' Your result goes here
  Set resCollection = Nothing
  For Each r In Selection.Rows
    XString = ActiveSheet.Cells(r.Row, XColumnNumber).Value
    YString = ActiveSheet.Cells(r.Row, YColumnNumber).Value
    Debug.Print "XString: "; XString
    Debug.Print "YString: "; YString
    XArray = Split(XString, ",")
    YArray = Split(YString, ",")
    For Each xe In XArray
      Debug.Print "xe:"; xe
      For Each ye In YArray
        Debug.Print "ye:"; ye
        If Trim(xe) = Trim(ye) Then
          Debug.Print "Same trimmed"
          found = False
          For Each res In resCollection
            If res = Trim(xe) Then
                found = True
                Exit For
            End If
          Next res
          Debug.Print "Found: "; found
          If Not (found) Then
            resCollection.Add Trim(xe)
            Debug.Print "Adding: "; xe
          End If
        End If
      Next ye
    Next xe
    Debug.Print "resCollection: "; resCollection.Count
    ZString = ""
    For Each res In resCollection
        ZString = ZString & Trim(res) & ", "
    Next res
    If Len(ZString) > 2 Then
      ZString = Left(ZString, Len(ZString) - 2)
    End If
    ActiveSheet.Cells(r.Row, ZColumnNumber).Value = ZString
  Next r
End Sub

Note if you have 2,1,2 and 2,5,2 and want 2,2 then remove the if Not Found part and add each time.