Find cells with similar values in a column

V

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

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
Sort by date Sort by votes
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
 
Upvote 0
Saurabhj said:
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
Click to expand...
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.
 
Upvote 0
sorry, but still the expected output is not clear. Great if you share an example.
 
Upvote 0
Saurabhj said:
sorry, but still the expected output is not clear. Great if you share an example.
Click to expand...

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: 34
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
Solution
Saurabhj said:
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
Click to expand...

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.
 
Upvote 0
aRandomHelper said:
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
Click to expand...

That's it. Thank you very much!!!
 
Upvote 0
You must log in or register to reply here.

Similar threads

togenmoser
  • Solved
Help with VBA code error "For variable already in use"
2 3
Replies
22
Views
327
MARK858
MARK858
F
  • Question
count the number of cells (in a range) greater than a cell value
Replies
9
Views
108
Flavien
F
S
  • Solved
VBA - Runtime Error 6 - Overflow
Replies
5
Views
88
ststern45
S
S
  • Question
Copies range from the wrong sheet
Replies
5
Views
333
kevin9999
K
H
  • Solved
Amend the VBA code to Filter Columns Instead of Rows
Replies
9
Views
156
Akuini
Akuini

Forum statistics

Threads
1,214,833
Messages
6,121,867
Members
449,053
Latest member
Mesh

Share this page

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
Back
Top