Problem with finding similar numbers in 2 columns in vba

user_12412772 0
Viewed 45

i have problem with my code in vba. I have to find how much similar numbers are in column 1 and 2, but for example Column 1 (6,6,34,21,23,40) and column2 (49,34,6,9,6,20) should write 3 cause there are pairs 6-6, 6-6 and 34-34. I know its messy explenation but i hope its understandable. My code so far is:

Sub totolotek()
    Dim i As Integer
    Dim x As Integer
    Dim j As Integer
    Dim liczba As Integer
    Dim suma As Integer
    Dim ileLosowan As Integer
    Range("B2:C7").Interior.Color = RGB(135, 134, 125)
    Range("B2:B7").Font.ColorIndex = 3
    Range("C2:C7").Font.ColorIndex = 5
    ileLosowan = 7
    Randomize
    For i = 2 To ileLosowan
        x = Int(Rnd * (49) + 1)
        Range("c" & i) = x
    Next i
For i = 2 To 7
    liczba = Range("c" & i)
    For j = 2 To 7
        liczbe = Range("b" & j)
        If liczbe = liczba Then
            Range("c" & i).Interior.Color = RGB(255, 255, 0)
            Range("b" & j).Interior.Color = RGB(255, 255, 0)
            suma = suma + 1
        End If
    Next j
Next i
Range("c" & 9) = suma
End Sub
vba excel
2 Answers

Try this. I invested some time and I added some lines of code. The macro find all the number pairs. Example (6,6,3,4,2) (2,3,6,9,0) --> results 3: (6-6, 3-3, 2-2)

Sub totolotek()
    Dim i As Integer
    Dim x As Integer
    Dim j As Integer
    Dim liczba As Integer
    Dim suma As Integer
    Dim ileLosowan As Integer
    Dim str_B As String, str_C As String, str_BC As String
    Dim max_rand As Long
    
    
    ileLosowan = 20                 ' you can change the number of element in the column
    max_rand = 49                   ' max randum number
    start_row = 2                   'start_row
    
    str_BC = "B2:C" & ileLosowan
    str_B = "B2:B" & ileLosowan
    str_C = "C2:C" & ileLosowan
    
    Range(str_BC).Interior.Color = RGB(135, 134, 125)
    Range(str_B).Font.ColorIndex = 5
    Range(str_C).Font.ColorIndex = 5


    Randomize
    For i = start_row To ileLosowan
        x = Int(Rnd * (max_rand) + 1)
        Range("C" & i) = x
    Next i
    For i = start_row To ileLosowan
        x = Int(Rnd * (max_rand) + 1)
        Range("B" & i) = x
    Next i

liczba_array = Range("B" & start_row & ":B" & ileLosowan).Value2
liczbe_array = Range("C" & start_row & ":C" & ileLosowan).Value2

ReDim ID_array(1 To 1)
ID_array(1) = max_rand + 1
Count = 1


For i = 1 To UBound(liczba_array, 1)
    For j = 1 To UBound(liczbe_array, 1)
        For k = 1 To UBound(ID_array, 1)
            If ID_array(k) = j Then
                GoTo out
            End If
        Next k
            If liczba_array(i, 1) = liczbe_array(j, 1) Then
                Range("B" & (start_row + i - 1)).Interior.Color = RGB(150 + Count * 20, 0, 0)
                Range("C" & (start_row + j - 1)).Interior.Color = RGB(150 + Count * 20, 0, 0)
                suma = suma + 1
                ID_array(Count) = j
                Count = Count + 1
                ReDim Preserve ID_array(1 To Count)
                Exit For
            End If
    Next j
out:
Next i
Range("C" & ileLosowan + 2) = suma
End Sub
user_62546090

Something like this will do what you're after. Just incorporate it into you're code cause I don't really know what's going on there.

Dim i As Long, j As Long, arr As Variant, Total As Integer

For i = 2 To 7 'Rows to loop through in the column
    Total = 0
    arr = Split(Range("A" & i), ",") 'Split column A using the comma
    For j = 0 To UBound(arr) 'Loop through the split values
        If InStr(Range("B" & i), arr(j)) > 0 Then 'Find if value is within other column
            Total = Total + 1 'If it is, add 1 to total
        End If
    Next j
    Range("C" & i) = Total 'Write total to another column on same row
Next i

Or if you want a basic function for it that you can use in your sheet you can use this:

Public Function CountMatches(Cell As String, Rng As Range, Optional Delim As String)

Dim i As Long, j As Long, arr As Variant, Total As Integer

If Delim = "" Then Delim = ","

If Rng.Count > 1 Then
    CountMatches = "Please choose 1 cell to compare to."
    Exit Function
End If

Total = 0
arr = Split(Cell, Delim) 'Split column A using the comma

For j = 0 To UBound(arr) 'Loop through the split values
    If InStr(Rng, arr(j)) > 0 Then 'Find if value is within other column
        Total = Total + 1 'If it is, add 1 to total
    End If
Next j

CountMatches = Total

End Function

Use it like =CountMatches(A1,B1,",")

user_26321650
Related