بفرض أن الأسماء أو الجمل المراد استخراج المتشابه منها تبدأ في الخلية A1 ... جرب هذا الكود بعد التخلص من التنسيق الشرطيكما يمكن من خلال الكود التحكم في نسبة التشابه (هذا الكود قدمته من فترة كحل لأحد الأعضاء) .. ورأيت وضعه هنا لإثراء الموضوع
CODE
Sub Test() Const s As Double = 0.75 Dim r1 As Long Dim r2 As Long Dim m As Long Dim c As Long Dim n As Long Application.ScreenUpdating = False Randomize With Sheets("Sheet1") m = .Range("A" & Rows.Count).End(xlUp).Row .Range("A1:A" & m).Interior.ColorIndex = xlColorIndexNone For r1 = 1 To m - 1 c = RGB(128 + 128 * Rnd, 128 + 128 * Rnd, 128 + 128 * Rnd) For r2 = r1 + 1 To m If .Range("A" & r2).Interior.ColorIndex = xlColorIndexNone Then If Similarity(.Range("A" & r1).Value, .Range("A" & r2).Value) > s Then .Range("A" & r1).Interior.Color = c .Range("A" & r2).Interior.Color = c End If End If Next r2 Next r1 For n = 1 To m 'If Last Column Is E Which Is 5 So Change Column Numbers To 6 And 7 .Cells(n, 6) = .Cells(n, 1).Interior.ColorIndex .Cells(n, 7) = .Cells(n, 1).Font.ColorIndex Next n 'Columns F & G Are Helper Columns So Change To Suit .Columns("A:G").Sort Key1:=.Range("F1"), Order1:=xlDescending, Key2:=Range("G1"), Order2:=xlAscending, Key3:=Range("A1"), Order3:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal .Columns("F:G").ClearContents End With Application.ScreenUpdating = TrueEnd SubPublic Function Similarity(ByVal String1 As String, ByVal String2 As String, Optional ByRef RetMatch As String, Optional min_match = 1) As Single Dim b1() As Byte Dim b2() As Byte Dim lngLen1 As Long Dim lngLen2 As Long Dim lngResult As Long If UCase(String1) = UCase(String2) Then Similarity = 1 Else lngLen1 = Len(String1) lngLen2 = Len(String2) If (lngLen1 = 0) Or (lngLen2 = 0) Then Similarity = 0 Else b1() = StrConv(UCase(String1), vbFromUnicode) b2() = StrConv(UCase(String2), vbFromUnicode) lngResult = Similarity_Sub(0, lngLen1 - 1, 0, lngLen2 - 1, b1, b2, String1, RetMatch, min_match) Erase b1: Erase b2 If lngLen1 >= lngLen2 Then Similarity = lngResult / lngLen1 Else Similarity = lngResult / lngLen2 End If End If End IfEnd FunctionPrivate Function Similarity_Sub(ByVal start1 As Long, ByVal end1 As Long, _ ByVal start2 As Long, ByVal end2 As Long, _ ByRef b1() As Byte, ByRef b2() As Byte, _ ByVal FirstString As String, _ ByRef RetMatch As String, _ ByVal min_match As Long, _ Optional recur_level As Integer = 0) As Long Dim lngCurr1 As Long Dim lngCurr2 As Long Dim lngMatchAt1 As Long Dim lngMatchAt2 As Long Dim i As Long Dim lngLongestMatch As Long Dim lngLocalLongestMatch As Long Dim strRetMatch1 As String Dim strRetMatch2 As String If (start1 > end1) Or (start1 < 0) Or (end1 - start1 + 1 < min_match) Or (start2 > end2) Or (start2 < 0) Or (end2 - start2 + 1 < min_match) Then Exit Function End If For lngCurr1 = start1 To end1 For lngCurr2 = start2 To end2 i = 0 Do Until b1(lngCurr1 + i) <> b2(lngCurr2 + i) i = i + 1 If i > lngLongestMatch Then lngMatchAt1 = lngCurr1 lngMatchAt2 = lngCurr2 lngLongestMatch = i End If If (lngCurr1 + i) > end1 Or (lngCurr2 + i) > end2 Then Exit Do Loop Next lngCurr2 Next lngCurr1 If lngLongestMatch < min_match Then Exit Function lngLocalLongestMatch = lngLongestMatch RetMatch = "" lngLongestMatch = lngLongestMatch + Similarity_Sub(start1, lngMatchAt1 - 1, start2, lngMatchAt2 - 1, b1, b2, FirstString, strRetMatch1, min_match, recur_level + 1) If strRetMatch1 <> "" Then RetMatch = RetMatch & strRetMatch1 & "*" Else RetMatch = RetMatch & IIf(recur_level = 0 And lngLocalLongestMatch > 0 And (lngMatchAt1 > 1 Or lngMatchAt2 > 1), "*", "") End If RetMatch = RetMatch & Mid$(FirstString, lngMatchAt1 + 1, lngLocalLongestMatch) lngLongestMatch = lngLongestMatch + Similarity_Sub(lngMatchAt1 + lngLocalLongestMatch, end1, lngMatchAt2 + lngLocalLongestMatch, end2, b1, b2, FirstString, strRetMatch2, min_match, recur_level + 1) If strRetMatch2 <> "" Then RetMatch = RetMatch & "*" & strRetMatch2 Else RetMatch = RetMatch & IIf(recur_level = 0 And lngLocalLongestMatch > 0 And ((lngMatchAt1 + lngLocalLongestMatch < end1) Or (lngMatchAt2 + lngLocalLongestMatch < end2)), "*", "") End If Similarity_Sub = lngLongestMatchEnd Function
دالة معرفة لتأكيد تشابه النصوص
ما شاء الله لا قوة إلا باللهأحسنتم أحسن الله إليكم
