Find cells with similar values in a column

[VladesMale87]

Hy,

I have in column A multiple strings of numbers that look like:

2222222266622222266666222222222222266622666666222
2222266666622222222666662222666222222666222222222
2222266622226666662266622266622222222222222222666
2222222222222666222226662266622226666622222222666
2666662266622222222222222222222666222222666222666
2222266622222666666666662266622222222222222222222
6662266622226662222266622222666222222266622222222
2666622666666222666222222666222222222222222222222
2222266626662666222222266622222222222666222266622 and so on.

I'm trying to find the values that are 90% the same or another percentage that I would choose before I run the program.

What I have so far is:

Sub Similar()
Dim stNow As Date
Dim DATAsheet As Worksheet
Dim firstrow As Integer
Dim finalrow As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim String_i, Len_i, String_j, Len_j
stNow = Now
   Application.EnableEvents = False
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
Set DATAsheet = Sheet1
DATAsheet.Select
firstrow = Cells(1, 2).End(xlDown).Row
finalrow = Cells(Rows.Count, 1).End(xlUp).Row
For i = firstrow To finalrow
  For j = firstrow To finalrow
    If i > 3 And j > 3 And i <> j Then
      String_i = Cells(i, 1).Value
      Len_i = Len(String_i)
      String_j = Cells(j, 1).Value
      Len_j = Len(String_j)
        For k = 1 To Len_i
         For l = 1 To Len_j
          If Mid(String_i, k, 1) = Mid(String_j, l, 1) Then
           Cells(j, 2).Value = Cells(j, 2).Value + 1
          End If
         Next l
        Next k
     End If
       DoEvents
   Next j
   Application.StatusBar = "Rutina 1/8 --- Done:   " & Round((i / finalrow * 100), 0) & " %"
Next i
Application.StatusBar = ""
MsgBox "Done"
   Application.EnableEvents = True
   Application.ScreenUpdating = True
   Application.Calculation = xlCalculationAutomatic
End Sub

,but it gives me in column B the results:
259461.00
262794.00
262794.00
262794.00
259461.00
266123.00
259461.00
259461.00 etc

Any help is appreciated.

Thanks!!!

 

[Saurabhj]

Hi, can you please confirm the expected output from each row. From the data given it's not clear what is the expected result ?

Thanks,
Saurabh

 

[VladesMale87]

Hi, can you please confirm the expected output from each row. From the data given it's not clear what is the expected result ?

Thanks,
Saurabh

The expected result should be in column B how many other cells would share the same structure as much as an percentage with column A, and if it is possible in next column or columns, the cells that gave that similitude.

 

[Saurabhj]

sorry, but still the expected output is not clear. Great if you share an example.

 

[VladesMale87]

sorry, but still the expected output is not clear. Great if you share an example.

I uploaded an image of the output that I'd like to achieve. Thanks!

 

[Saurabhj]

Hi,

Thanks for sharing the screenshot. Please use below code.

Sub calculate()
Application.ScreenUpdating = False
Dim totalRows As Integer
totalRows = Sheets("Sheet1").Cells(Rows.count, 1).End(xlUp).Row

'MsgBox totalRows
Dim counter As Integer, startCheck As Integer, similarCellCounter As Integer, nextCol As Integer
startCheck = 2


Do While startCheck <= totalRows
    nextCol = 3
    similarCellCounter = 0
    For counter = startCheck + 1 To totalRows
        If Sheets("Sheet1").Range("A" & startCheck) = Sheets("Sheet1").Range("A" & counter) Then
            similarCellCounter = similarCellCounter + 1
            Sheets("Sheet1").Range("B" & startCheck) = similarCellCounter
            Sheets("Sheet1").Cells(startCheck, nextCol) = Sheets("Sheet1").Range("A" & counter).Address
            nextCol = nextCol + 1
        End If
    Next
    startCheck = startCheck + 1
Loop
Application.ScreenUpdating = True
End Sub

 

[aRandomHelper]

Amended your code to do what you want:

Sub Similar()
    Dim stNow As Date
    Dim DATAsheet As Worksheet
    Dim firstrow As Long, finalrow As Long, p As Double, c As Long, col As Long
    Dim i As Long, j As Long, k As Long, l As Long, Len_i As Long, Len_j As Long
    Dim String_i, String_j
    Const similarity As Double = 70 '% similarity
    
    stNow = Now
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Set DATAsheet = Sheet1
    DATAsheet.Select
    firstrow = 2
    finalrow = Cells(Rows.Count, 1).End(xlUp).Row
    
    For i = firstrow To finalrow
        col = 3
        For j = firstrow To finalrow
            If i <> j Then
                String_i = Cells(i, 1).Value
                Len_i = Len(String_i)
                String_j = Cells(j, 1).Value
                Len_j = Len(String_j)
                p = 0
                c = 0
                For k = 1 To Len_i
                    If Mid(String_i, k, 1) = Mid(String_j, k, 1) Then c = c + 1
                Next k
                If (c / Len_i * 100) >= similarity Then
                    Cells(i, col).Value = Cells(j, 1).Address(0, 0)
                    col = col + 1
                End If
            End If
            DoEvents
        Next j
        Cells(i, 2).Value = Application.CountA(Range(Cells(i, 3), Cells(i, col)))
        Application.StatusBar = "Rutina 1/8 --- Done:   " & Round((i / finalrow * 100), 0) & " %"
    Next i
    
    Application.StatusBar = ""
    MsgBox "Done"
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Set similarity to the percentage similarity you want. This is also assuming that all your data has the same length of string, and the structure looks like the screenshot in post #5

 

[VladesMale87]

Hi,

Thanks for sharing the screenshot. Please use below code.

Sub calculate()
Application.ScreenUpdating = False
Dim totalRows As Integer
totalRows = Sheets("Sheet1").Cells(Rows.count, 1).End(xlUp).Row

'MsgBox totalRows
Dim counter As Integer, startCheck As Integer, similarCellCounter As Integer, nextCol As Integer
startCheck = 2


Do While startCheck <= totalRows
    nextCol = 3
    similarCellCounter = 0
    For counter = startCheck + 1 To totalRows
        If Sheets("Sheet1").Range("A" & startCheck) = Sheets("Sheet1").Range("A" & counter) Then
            similarCellCounter = similarCellCounter + 1
            Sheets("Sheet1").Range("B" & startCheck) = similarCellCounter
            Sheets("Sheet1").Cells(startCheck, nextCol) = Sheets("Sheet1").Range("A" & counter).Address
            nextCol = nextCol + 1
        End If
    Next
    startCheck = startCheck + 1
Loop
Application.ScreenUpdating = True
End Sub

Very nice code, but it's only for the 100% similar. I want, if it is possible, to change in code or to input manual thru a form a percentage (90% in the screenshot), and to check for the cells that have 44 characters of 50 the same, and those results to be the output.

 

[VladesMale87]

Amended your code to do what you want:

Sub Similar()
    Dim stNow As Date
    Dim DATAsheet As Worksheet
    Dim firstrow As Long, finalrow As Long, p As Double, c As Long, col As Long
    Dim i As Long, j As Long, k As Long, l As Long, Len_i As Long, Len_j As Long
    Dim String_i, String_j
    Const similarity As Double = 70 '% similarity
   
    stNow = Now
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Set DATAsheet = Sheet1
    DATAsheet.Select
    firstrow = 2
    finalrow = Cells(Rows.Count, 1).End(xlUp).Row
   
    For i = firstrow To finalrow
        col = 3
        For j = firstrow To finalrow
            If i <> j Then
                String_i = Cells(i, 1).Value
                Len_i = Len(String_i)
                String_j = Cells(j, 1).Value
                Len_j = Len(String_j)
                p = 0
                c = 0
                For k = 1 To Len_i
                    If Mid(String_i, k, 1) = Mid(String_j, k, 1) Then c = c + 1
                Next k
                If (c / Len_i * 100) >= similarity Then
                    Cells(i, col).Value = Cells(j, 1).Address(0, 0)
                    col = col + 1
                End If
            End If
            DoEvents
        Next j
        Cells(i, 2).Value = Application.CountA(Range(Cells(i, 3), Cells(i, col)))
        Application.StatusBar = "Rutina 1/8 --- Done:   " & Round((i / finalrow * 100), 0) & " %"
    Next i
   
    Application.StatusBar = ""
    MsgBox "Done"
   
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Set similarity to the percentage similarity you want. This is also assuming that all your data has the same length of string, and the structure looks like the screenshot in post #5

That's it. Thank you very much!!!