Compare columns and return matching text VBA

Hi alekos,

Give this a try:

Sub compare()
'compares 2 lists by adding them to an array and then outputs a list of common and unique values
Dim Arr As Variant
Dim vArr As Variant
Dim wss As Worksheet
Dim x, y
Dim match As Boolean
Dim j As Long

Application.ScreenUpdating = False

Set wss = ThisWorkbook.Worksheets("Sheet1") 'sheet with source data
'get the values in columns A and B into arrays for comparison, adjust the column letters if needed
Arr = wss.Range("A2:A" & wss.Range("A" & Rows.Count).End(xlUp).Row).Value 'starts at A2 assuming a header
vArr = wss.Range("B2:B" & wss.Range("B" & Rows.Count).End(xlUp).Row).Value 'starts at B2 assuming a header
j = 1 'will start the list of values that are in both lists on row 2 because later we add 1 before writing
'here we compare lists, output what is common to both
For Each x In Arr
    match = False
    For Each y In vArr
        If x = y Then 'there is a match in col A vs Col B
            match = True
            j = j + 1
            wss.Range("C" & j).Value = x 'write the value of X in the list of common values.  "C" is the output column
        End If
    Next y
Next x

Application.ScreenUpdating = True

End Sub

oops... just realized it is not necessarily a list... could use Split function instead... a sample sheet would be ideal

try this WORK FOR ME

Sub tess()
Dim r As Range, dic As Object, t$, k, i&, sp, ii&, sp1$, lr&
Set dic = CreateObject("scripting.dictionary")
With Worksheets("Example")
    lr = .UsedRange.SpecialCells(11).Row
    Set r = .Range("b2:D" & lr)
      x = r.Value
      For i = 1 To UBound(x)
         t = x(i, 1) & ";" & x(i, 2)
         sp = Split(t, ";")
          For ii = 0 To UBound(sp)
             If Not dic.exists(Trim$(sp(ii))) Then
                dic(sp(ii)) = sp(ii)
             Else
                dic(sp(ii)) = dic(Trim$(sp(ii))) & "," & Trim$(sp(ii))
             End If
          Next ii
         For Each k In dic.keys
            If InStr(dic(k), ",") Then
              sp1 = IIf(sp1 = "", k, sp1 & ";" & k)
            End If
         Next k
          x(i, 3) = sp1
          sp1 = "": sp = "": dic.RemoveAll
      Next i
        .[d2].Resize(lr - 1) = Application.Index(x, 0, 3)
 End With
End Sub

Originally Posted by alekos7

This is brilliant! I tried setting it up as a loop (my actual data set is exponentially larger), but I'm getting a subscript out of range error. I need this to run 68 times across the set of 2 columns & output in the 3rd column each time (columns are all next to each other). Is there any way to set it up to run a loop through those instead of defining each specific range?

Set r = .Range("b2:D" & lr)
Set r = .Range("e2:G" & lr)
Set r = .Range("h2:J" & lr)
.
.
.
Set r = .Range("gu2:GW" & lr)

You just add range array

Dim r(1 to 3)
Set r(1) =.range("b2:d" & lr)
Set r(2) = .range("e2:g" & lr)
Set r(3) = .range("h2:j" & lr)
'etc
'you can loop
For rw = 1 to 3
   x = r(rw).value
   'add my code to this
    


Next rw

Or if your range is have sama space with other you can loop

For myrange = 1 to 3 'asumsi 3 areas range
   With sheets("Example")
   x= .range(b2).resize(.usedrange.specialcell(11).row,3)
   'add my code above to thid
   'small change to after next i

   '.[d2].resize(ubound(x)) = x
   'change to
   .columns(Ubound(x,2)).offset(1) = x

   j = j + 4 'for move to next range

How about:

Sub compare()
'compares 2 lists by adding them to an array and then outputs a list of common and unique values
Dim Arr As Variant
Dim vArr As Variant
Dim wss As Worksheet
Dim x, y
Dim match As Boolean
Dim j As Long
Dim i As Long
Dim lr As Long
Dim namesList As String

Application.ScreenUpdating = False

Set wss = ThisWorkbook.Worksheets("Example") 'sheet with source data

lr = wss.Range("B" & Rows.Count).End(xlUp).Row 'last row with data in Col B

For i = 2 To lr
    'get the values in columns A and B into arrays for comparison, adjust the column letters if needed
    Arr = Split(wss.Range("B" & i).Value, ";")
    vArr = Split(wss.Range("C" & i).Value, ";")
    namesList = vbNullString
    match = False
    'here we compare lists, output what is common to both
    For Each x In Arr
        For Each y In vArr
            If x = y Then 'there is a match in col A vs Col B
                match = True
                namesList = namesList & x & ";"
            End If
        Next y
    Next x
    If match = True Then
        'remove trailing ";"
        namesList = Left(namesList, Len(namesList) - 1)
        wss.Range("D" & i).Value = namesList
    End If
Next i
Application.ScreenUpdating = True

End Sub

And perhab you can change to this
I am sorri not test
Or another idea
'b,e,h

Sub xxx (r as range,sh as string)
Dim dic As Object, t$, k, i&, sp, ii&, sp1$, lr&
Set dic = CreateObject("scripting.dictionary")
Sheets(sh).Activate
      x = r.Value
      For i = 1 To UBound(x)
         t = x(i, 1) & ";" & x(i, 2)
         sp = Split(t, ";")
          For ii = 0 To UBound(sp)
             If Not dic.exists(Trim$(sp(ii))) Then
                dic(sp(ii)) = sp(ii)
             Else
                dic(sp(ii)) = dic(Trim$(sp(ii))) & "," & Trim$(sp(ii))
             End If
          Next ii
         For Each k In dic.keys
            If InStr(dic(k), ",") Then
              sp1 = IIf(sp1 = "", k, sp1 & ";" & k)
            End If
         Next k
          x(i, 3) = sp1
          sp1 = "": sp = "": dic.RemoveAll
      Next i
       r.columns(3).offset(1).Resize(r.rows
Count-1) = Application.Index(x, 0, 3)
End Sub

In other code you can call

Sub tesss()
Dim lr as long
lr = activesheet.usedrange.specialcells(11).row
xxx Sheets("Example").range("b2:d" & lr),"Example"

'second range
xxx sheets("Example").range("e2:g" & lr),"Example"

'third range etc