Find cells with similar values in a column

VladesMale87

New Member
Joined
Jan 25, 2021
Messages
5
Office Version
  1. 2019
Platform
  1. Windows
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:

VBA Code:
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!!!
 

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.

Saurabhj

Active Member
Joined
Jun 6, 2020
Messages
414
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
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

New Member
Joined
Jan 25, 2021
Messages
5
Office Version
  1. 2019
Platform
  1. Windows
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

Active Member
Joined
Jun 6, 2020
Messages
414
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
sorry, but still the expected output is not clear. Great if you share an example.
 

VladesMale87

New Member
Joined
Jan 25, 2021
Messages
5
Office Version
  1. 2019
Platform
  1. Windows

ADVERTISEMENT

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!
 

Attachments

  • Find cells with similar values in a column.jpg
    Find cells with similar values in a column.jpg
    253.7 KB · Views: 12

Saurabhj

Active Member
Joined
Jun 6, 2020
Messages
414
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
Hi,

Thanks for sharing the screenshot. Please use below code.

VBA 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

Active Member
Joined
Jan 14, 2021
Messages
278
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

Amended your code to do what you want:
VBA Code:
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
 
Solution

VladesMale87

New Member
Joined
Jan 25, 2021
Messages
5
Office Version
  1. 2019
Platform
  1. Windows
Hi,

Thanks for sharing the screenshot. Please use below code.

VBA 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

New Member
Joined
Jan 25, 2021
Messages
5
Office Version
  1. 2019
Platform
  1. Windows
Amended your code to do what you want:
VBA Code:
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!!!
 

Watch MrExcel Video

Forum statistics

Threads
1,129,930
Messages
5,639,054
Members
417,067
Latest member
rohitbabshet

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top