Comparing text?
Hi, please ignore the previous code. Please use the following.
Const ROW_MAIN As Integer = 1
Const ROW_OTHER As Integer = 2
Const ROW_RESULT As Integer = 3
'
Sub myCompare()
Dim str1, str2 As String
Dim tCell As Range
' GET THE TEXTS TO BE COMPARED
Set tCell = Cells(ROW_MAIN, 1)
str1 = Trim(tCell.Value)
Set tCell = Cells(ROW_OTHER, 1)
str2 = Trim(tCell.Value)
Set tCell = Nothing
' PERFORM CHAR-BY-CHAR COMPARISON AND COUNT MATCHES
Dim size1, size2, size3 As Long
Dim half, oneThird, percent1, percent2, percent3 As Double
Dim per, status, err_msg As String
size1 = Len(str1)
size2 = Len(str2)
err_msg = ""
' CHECK IF ANY TEXT IS EMPTY
If Not size1 = 0 And size2 = 0 Then
err_msg = "Please enter a text for comparison in row " & ROW_OTHER
GoTo prn_abnorm_result
ElseIf size1 = 0 And Not size2 = 0 Then
err_msg = "Please enter a text for comparison in row " & ROW_MAIN
GoTo prn_abnorm_result
ElseIf size1 = 0 And size2 = 0 Then
err_msg = "Please enter some text for comparison in rows " & ROW_MAIN & "
and " & ROW_OTHER
GoTo prn_abnorm_result
ElseIf size1 < size2 Then
err_msg = "Text to be compared is longer than the original text"
GoTo prn_abnorm_result
ElseIf size1 size2 Then
err_msg = "Text to be compared is shorter than the original text"
GoTo prn_abnorm_result
End If
size3 = countMismatch(str1, str2)
If size3 = 0 Then
showMsg "RESULT : Matches 100%"
GoTo end_of_sub
ElseIf size3 = size1 Then
showMsg "RESULT : Mismatches 100%"
GoTo end_of_sub
Else
status = "not "
per = "by "
percent1 = Round(size1 / 100, 2)
percent2 = Round(Abs(size2 - size3) / 100, 2)
percent3 = Round((percent2 / percent1) * 100, 2)
per = per & percent3
If (size3 < Round(size1 / 2, 2) And percent3 = 50#) Or (size3
Round(size1 / 2, 2) And percent3 < 50#) Then status = ""
End If
prn_norm_result:
' PRINT NORMAL RESULT
showMsg "RESULT : Text in second row does " & status & "match that in first
row, " & per & " %"
GoTo end_of_sub
prn_abnorm_result:
showMsg "ERROR : " & err_msg
end_of_sub:
End Sub
'
Function countMismatch(ByVal argStr1 As String, ByVal argStr2 As String) As
Integer
Dim i, size As Long
Dim val As Integer
size = Len(argStr1)
val = 0
For i = 1 To size
If Not Mid(argStr1, i, 1) = Mid(argStr2, i, 1) Then val = val + 1
Next i
countMismatch = val
End Function
'
Sub showMsg(ByVal argMsg As String)
Dim tCell As Range
Dim col As Integer
If Left(argMsg, 3) = "ERR" Then col = 255 Else col = 0
Set tCell = Cells(ROW_RESULT, 1)
With tCell
.Value = argMsg
.Font.Bold = True
.Font.Color = RGB(col, 0, 0)
End With
End Sub
"Madhan" wrote:
Hi, please find below a sample code. I hope it helps you. Try entering in A1
the main text and in A2 the text to be compared. Call myCompare from a macro.
Const ROW_MAIN As Integer = 1
Const ROW_OTHER As Integer = 2
Const ROW_RESULT As Integer = 3
'
Sub myCompare()
Dim str1, str2 As String
Dim tCell As Range
' GET THE TEXTS TO BE COMPARED
Set tCell = Cells(ROW_MAIN, 1)
str1 = Trim(tCell.Value)
Set tCell = Cells(ROW_OTHER, 1)
str2 = Trim(tCell.Value)
Set tCell = Nothing
' PERFORM CHAR-BY-CHAR COMPARISON AND COUNT MATCHES
Dim size1, size2, size3 As Long
Dim half, oneThird, percent1, percent2, percent3 As Double
Dim per, status, err_msg As String
size1 = Len(str1)
size2 = Len(str2)
err_msg = ""
' CHECK IF ANY TEXT IS EMPTY
If Not size1 = 0 And size2 = 0 Then
err_msg = "Please enter a text for comparison in row " & ROW_OTHER
GoTo prn_abnorm_result
End If
If size1 = 0 And Not size2 = 0 Then
err_msg = "Please enter a text for comparison in row " & ROW_MAIN
GoTo prn_abnorm_result
End If
If size1 = 0 And size2 = 0 Then
err_msg = "Please enter some text for comparison in rows " & ROW_MAIN & "
and " & ROW_OTHER
GoTo prn_abnorm_result
End If
' CHECK IF SIZES DO NOT MATCH
status = ""
per = "by 100"
If Not size1 = size2 Then
status = "not "
oneThird = size1 / 4
half = size1 / 2
If size2 = oneThird And size2 <= half Then
per = "between 50 and 75"
GoTo prn_norm_result
End If
If size2 < oneThird Then
per = "by more-than 75"
GoTo prn_norm_result
End If
If size2 size1 Then
per = "by more-than 100"
GoTo prn_norm_result
End If
End If
percent1 = Round(size1 / 100, 2)
size3 = countMismatch(str1, str2)
status = "not "
per = "by 100"
If Not size3 = 0 Then
If Not size3 = size1 Then
percent2 = Round(Abs(size2 - size3) / 100, 2)
percent3 = Round((percent2 / percent1) * 100, 2)
If percent3 = 50# Then status = "" Else status = "not "
per = "by " & percent3
End If
End If
prn_norm_result:
' PRINT NORMAL RESULT
showMsg "RESULT : Text in second row does " & status & "match that in first
row, " & per & " %"
GoTo end_of_sub
prn_abnorm_result:
showMsg "ERROR : " & err_msg
end_of_sub:
End Sub
'
Function countMismatch(ByVal argStr1 As String, ByVal argStr2 As String) As
Integer
Dim i, size As Long
Dim val As Integer
size = Len(argStr1)
val = 0
For i = 1 To size
If Not Mid(argStr1, i, 1) = Mid(argStr2, i, 1) Then val = val + 1
Next i
countMismatch = val
End Function
'
Sub showMsg(ByVal argMsg As String)
Dim tCell As Range
Dim col As Integer
If Left(argMsg, 3) = "ERR" Then col = 255 Else col = 0
Set tCell = Cells(ROW_RESULT, 1)
With tCell
.Value = argMsg
.Font.Bold = True
.Font.Color = RGB(col, 0, 0)
End With
Set tCell = Nothing
End Sub
" wrote:
On Feb 19, 11:38 am, Madhan wrote:
Hi, yes it is possible. You can do the following,
1. Find the number of characters in one cell and assume that it is 100%
2. Check character-by-character the exactness of characters in both the
cells and count the match
3. Calculate % from the count of matched characters
" wrote:
I asked this question in a roundabout way last week with no success.
Basically, is it possible to compare text of one cell to another cell
to produce a % of correctness. It doesn't have to be exact as I am
only using it to set up a French revision spreadsheet.
I know it's a tricky one but any help would be great. Over to the
experts!
Thanks
Tony- Hide quoted text -
- Show quoted text -
Thanks Madhan,
To be honest I am not sure how to do this and wouldn't know where to
start (my Excel knowledge is very limited) - can you help?
Thanks
Tony
|