أكاديمية الصقر للتدريب

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
مالك ماريه Eslam Abdullah-- لا تميز خلال هذه الفترة YasserKhalil عمل تنبيه على الوندز عند تشغيل الجهاز اكسيل اسئله واجابات


اعلان هنا
ألعاب فلاش أون لاين
أعلن هنا
أعلن هنا
صفحتنا على الفيس بوك
أعلن هنا



أهلا وسهلا بك زائرنا الكريم في أكاديمية الصقر للتدريب، لكي تتمكن من المشاركة ومشاهدة جميع أقسام المنتدى وكافة الميزات ، يجب عليك إنشاء حساب جديد بالتسجيل بالضغط هنا أو تسجيل الدخول اضغط هنا إذا كنت عضواً .





دالة معرفة لتأكيد تشابه النصوص

بســـــم الله والحـمد للـــه والصـلاة والسـلام علـى رسـول اللهأهلا ومرحبا بكم أخوانى الكرام من جديدومعكم عريف مجند من ال ..



25-05-2019 12:23 مساء
Eslam Abdullah
menu_open
مشرف على لغات برمجة آخرى
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 03-10-2017
رقم العضوية : 852
المشاركات : 1440
الجنس : ذكر
تاريخ الميلاد : 1-9-1995
الدعوات : 4
يتابعهم : 0
يتابعونه : 74
قوة السمعة : 9048
الاعجاب : 195
 offline 

بســـــم الله والحـمد للـــه والصـلاة والسـلام علـى رسـول الله
أهلا ومرحبا بكم أخوانى الكرام من جديد
ومعكم عريف مجند من القوات المسلحه فى أجازة جديده من جديد الجديد biggrin2
وفى فقرة سؤال وجواب
كان السؤال بإحدى جروبات الفيس بوك من أخونا مأمون مصطفى
طرح أخونا مأمون سؤال جميل وهو كما بالصورة التالية
FvPAZ_2019-05-25_113923
وكما بالصورة أخونا مأمون عايز يستخدم التنسيق الشرطى لتلوين النص المتشابه وليس المتطابق
وأعطى أمثله منها

محمد سعد , محمد السعد , محمد سعدى
من المفترض هنا أن ثلاثتهم متشابهين
ومن هنا تأتى إحدى الدوال المعرفة من دوال الصقر للإنقاذ biggrin2
دالة AlsaqrSimilar
الدالة تقوم بإكتشاف النصوص المتشابه وترجع قيمة منطقية إما TRUE أو FALSE

وحســـب الطلب هو قايل تشابه النص حسب اكبر عدد من الحروف
وأنا لقيت بعض النصوص قد تكون بها تشابه كبير فى الحروف
الى انها متباعده ولا تعطى أى نوع من أنواع التشابه
ولذلــــــــــــــك
قمت بتلافى هذا النوع من التشابه والتجربه تعود لكم فى النهايه اذا كان هناك اختلاف بالأراء
اذا استخدام الدالة كالتالى

C B A -
=AlsaqrSimilar($A$1:$A$8,A1) TRUE محمد سعد 1
=AlsaqrSimilar($A$1:$A$8,A2) TRUE محمد السعد 2
=AlsaqrSimilar($A$1:$A$8,A3) TRUE محمد سعدى 3
=AlsaqrSimilar($A$1:$A$8,A4) FALSE اسلام عبدالعزيز 4
=AlsaqrSimilar($A$1:$A$8,A5) FALSE حسام خطاب 5
=AlsaqrSimilar($A$1:$A$8,A6) FALSE ياسر خليل 6
=AlsaqrSimilar($A$1:$A$8,A7) TRUE ياسر العربى 7
=AlsaqrSimilar($A$1:$A$8,A8) TRUE ياسر عربى 8

وكما موضح بالجدول أعلاه استخدام الدالة بسيط جدا
تتكون من 2 باراميتر
الأول هو النطاق المراد اختبار تكرار تشابه النص بها
والثانى هى الخلية المراد اختبار تكرارها بالتشابه داخل النطاق المحدد

ويمكن استخدام تلك القيم فى التنسيق الشرطى

لتظليل النصوص المتشابهه بنفس الطريقة
وكود الدالة هو
Function AlsaqrSimilar(rng As Range, criteria As Variant) As Boolean
'Developer: Eslam Abdullah
Dim serial%, a%, i%, str$, address$, chk As Boolean, cell As Variant
address = criteria.address: criteria = Application.Trim(criteria)

For Each cell In rng
If cell.address = address Then GoTo 1
cell = Application.Trim(cell)
str = cell
a = 0
For i = 1 To Len(criteria)
serial = InStr(str, Mid(criteria, i, 1))
If serial > 0 Then
If a > 0 And serial > 1 And chk Then Exit For
chk = Left(str, 1) <> " " And Mid(str, serial, 1) <> Mid(criteria, i, 1)
str = Mid(str, serial + 1)
a = a + 1
Else
If Mid(str, 1) = " " Or str = "" Then Exit For
End If
Next i
If Round(a / (Len(cell) + (Len(cell) = 0)) * 100) > 70 Then AlsaqrSimilar = True: Exit Function
1: Next cell
End Function

واليكم بملف مرفق بالتطبيق العملى على ورقة العمل وبالتنسيق الشرطى
لتحميــــــــــــــــل الملف من الرابط التـالــــــى
لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب



























 
 


أثارت هذه المشاركة إعجاب: Yasser Elaraby، YasserKhalil، محمد حسن المحمد، ali mohamed ali، abdulwahed catran، مالك ماريه، mohamed omar، محمد الدسوقى، sobhi67،





25-05-2019 01:34 مساء
مشاهدة مشاركة منفردة [1]
Yasser Elaraby
menu_open عضوية موثقة
المشرف العام
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 1
المشاركات : 1192
الجنس : ذكر
الدعوات : 13
مشاركات مكتبة الميديا: 25
يتابعهم : 2
يتابعونه : 599
قوة السمعة : 8643
الاعجاب : 460
موقعي : زيارة موقعي
 offline 
look/images/icons/i1.gif دالة معرفة لتأكيد تشابه النصوص
منور ياغالي ايه الشغل الحلو دا
جزاكم الله خيرا
2015_1418710703_134


أثارت هذه المشاركة إعجاب: Eslam Abdullah،


توقيع :Yasser Elaraby
663013020



25-05-2019 02:17 مساء
مشاهدة مشاركة منفردة [2]
Eslam Abdullah
menu_open
مشرف على لغات برمجة آخرى
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 03-10-2017
رقم العضوية : 852
المشاركات : 1440
الجنس : ذكر
تاريخ الميلاد : 1-9-1995
الدعوات : 4
يتابعهم : 0
يتابعونه : 74
قوة السمعة : 9048
الاعجاب : 195
 offline 
look/images/icons/i1.gif دالة معرفة لتأكيد تشابه النصوص
ميغسى بوكو أغالى هذا بعض ما عندكم biggrin2

أثارت هذه المشاركة إعجاب: Yasser Elaraby، محمد حسن المحمد،




26-05-2019 12:14 صباحا
مشاهدة مشاركة منفردة [3]
YasserKhalil
menu_open عضوية موثقة
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 7234
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 19
يتابعهم : 0
يتابعونه : 410
قوة السمعة : 20696
الاعجاب : 1430
 offline 
look/images/icons/i1.gif دالة معرفة لتأكيد تشابه النصوص
الله ينور يا سمسم .. بارك الله فيك وجزيت خيراً
وكل عام وأنت بخير

أثارت هذه المشاركة إعجاب: Eslam Abdullah، محمد حسن المحمد،




26-05-2019 12:41 صباحا
مشاهدة مشاركة منفردة [4]
Eslam Abdullah
menu_open
مشرف على لغات برمجة آخرى
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 03-10-2017
رقم العضوية : 852
المشاركات : 1440
الجنس : ذكر
تاريخ الميلاد : 1-9-1995
الدعوات : 4
يتابعهم : 0
يتابعونه : 74
قوة السمعة : 9048
الاعجاب : 195
 offline 
look/images/icons/i1.gif دالة معرفة لتأكيد تشابه النصوص
مشكور لمرورك الكريم أستاذى الغالى ياسر
كل عام وانت بألف خير

أثارت هذه المشاركة إعجاب: محمد حسن المحمد، YasserKhalil، مالك ماريه،




26-05-2019 08:00 صباحا
مشاهدة مشاركة منفردة [5]
محمد حسن المحمد
menu_open
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 24-08-2017
رقم العضوية : 80
المشاركات : 598
الجنس : ذكر
تاريخ الميلاد : 14-5-1965
الدعوات : 1
يتابعهم : 63
يتابعونه : 29
قوة السمعة : 3134
الاعجاب : 220
 offline 
look/images/icons/i1.gif دالة معرفة لتأكيد تشابه النصوص
890264
ما شاء الله لا قوة إلا بالله
أحسنتم أحسن الله إليكم
123

أثارت هذه المشاركة إعجاب: YasserKhalil، Eslam Abdullah،


توقيع :محمد حسن المحمد

الرفقُ ما كان في شيءٍ إلاَّ زانهُ ، وما نُزع من شيءٍ إلاَّ شانُه ،اللينُ في الخطاب ، البسمةُ الرائقةُ على المحيا، 
الكلمةُ الطيبةُ عند اللقاء ، هذه حُلَلٌ منسوجةٌ يرتديها السعداء



26-05-2019 09:42 صباحا
مشاهدة مشاركة منفردة [6]
ali mohamed ali
menu_open
مشرف على منتدى الاكسيل
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 20-11-2017
رقم العضوية : 1757
المشاركات : 1204
الدولة : مصر
الجنس : ذكر
الدعوات : 1
يتابعهم : 0
يتابعونه : 52
قوة السمعة : 5694
الاعجاب : 704
 Online 
look/images/icons/i1.gif دالة معرفة لتأكيد تشابه النصوص
رائع استاذ اسلام بارك الله فيك وجعله الله فى ميزان حسناتك وزادك الله من فضله

أثارت هذه المشاركة إعجاب: YasserKhalil، Eslam Abdullah،


توقيع :ali mohamed ali
{ وَقُل رَّبِّ زِدْنِي عِلْمًا }
[ كن على يقين من اعمالنا نخطئ ومن اخطائنا نتعلم ولذلك لا شي مستحيل ]
ساهم دائماً فى حل أى مشكلة او أستفسار لديك مع إضافة رد بشكره
أو دعوة لمن قدم اليك المساعدة,فالجميع هنا يعمل على مساعدة
 الاخرين لوجه الله وان تحتسب له اجر عند الله


26-05-2019 11:39 صباحا
مشاهدة مشاركة منفردة [7]
YasserKhalil
menu_open عضوية موثقة
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 7234
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 19
يتابعهم : 0
يتابعونه : 410
قوة السمعة : 20696
الاعجاب : 1430
 offline 
look/images/icons/i1.gif دالة معرفة لتأكيد تشابه النصوص
بفرض أن الأسماء أو الجمل المراد استخراج المتشابه منها تبدأ في الخلية A1 ... جرب هذا الكود بعد التخلص من التنسيق الشرطي
كما يمكن من خلال الكود التحكم في نسبة التشابه (هذا الكود قدمته من فترة كحل لأحد الأعضاء) .. ورأيت وضعه هنا لإثراء الموضوع
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 = True
End Sub

Public 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 If
End Function

Private 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 = lngLongestMatch
End Function

أثارت هذه المشاركة إعجاب: Eslam Abdullah، ali mohamed ali، مالك ماريه، صلاح الصغير،




27-05-2019 03:08 صباحا
مشاهدة مشاركة منفردة [8]
Eslam Abdullah
menu_open
مشرف على لغات برمجة آخرى
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 03-10-2017
رقم العضوية : 852
المشاركات : 1440
الجنس : ذكر
تاريخ الميلاد : 1-9-1995
الدعوات : 4
يتابعهم : 0
يتابعونه : 74
قوة السمعة : 9048
الاعجاب : 195
 offline 
look/images/icons/i1.gif دالة معرفة لتأكيد تشابه النصوص
عمل رائع أستاذى الغالى
انا بس حاولت اطبق اول اجراء باسم test مش راضى ممكن ملف عمل بالتطبيق
واثراء للموضوع اكثر اليك بدالة معرفة أخرى لإستخراج نسبة التشابه بين نصين
Function SimilarEA(text1 As String, text2 As String) As Double
'Developer: Eslam Abdullah
Dim serial%, a%, i%, str$
str = text2
For i = 1 To Len(text1)
serial = InStr(str, Mid(text1, i, 1))
If serial > 0 Then
str = Mid(str, 1, serial - 1) & Mid(str, serial + 1)
a = a + 1
Else
If str = "" Then Exit For
End If
Next i
If text1 & text2 = "" Then SimilarEA = 1 Else SimilarEA = a / Application.Max(Len(text1), Len(text2))
End Function


مثال على الدالة
Sub Alsaqr_test()
Const text1 = "اسلام عبدالعزيز"
Const text2 = "اسلام عبدالله"
MsgBox "The similarity ratio is " & FormatPercent(SimilarEA(text1, text2), 0)
End Sub








أثارت هذه المشاركة إعجاب: محمد حسن المحمد، مالك ماريه،




27-05-2019 08:56 صباحا
مشاهدة مشاركة منفردة [9]
YasserKhalil
menu_open عضوية موثقة
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 7234
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 19
يتابعهم : 0
يتابعونه : 410
قوة السمعة : 20696
الاعجاب : 1430
 offline 
look/images/icons/i1.gif دالة معرفة لتأكيد تشابه النصوص
دالة رائعة أخي الغالي إسلام
بالنسبة للملف المرفق هو نفسه ملفك ولكن اجعل الأسماء تبدأ من أول خلية A1 واحذف التنسيق الشرطي .. 142

أثارت هذه المشاركة إعجاب: Eslam Abdullah،




27-05-2019 11:36 صباحا
مشاهدة مشاركة منفردة [10]
مالك ماريه
menu_open
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 15-12-2017
رقم العضوية : 2523
المشاركات : 550
الجنس : ذكر
تاريخ الميلاد : 13-3-1990
يتابعهم : 3
يتابعونه : 8
قوة السمعة : 865
الاعجاب : 106
 offline 
look/images/icons/i1.gif دالة معرفة لتأكيد تشابه النصوص
بارك الله فيكم جميعا استاذى الغالى استاذ ياسر واخى الحبيب الاستاذ اسلام عبدالله وجزاكم الله خير

أثارت هذه المشاركة إعجاب: YasserKhalil، Eslam Abdullah،




27-05-2019 12:28 مساء
مشاهدة مشاركة منفردة [11]
Eslam Abdullah
menu_open
مشرف على لغات برمجة آخرى
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 03-10-2017
رقم العضوية : 852
المشاركات : 1440
الجنس : ذكر
تاريخ الميلاد : 1-9-1995
الدعوات : 4
يتابعهم : 0
يتابعونه : 74
قوة السمعة : 9048
الاعجاب : 195
 offline 
look/images/icons/i1.gif دالة معرفة لتأكيد تشابه النصوص
المشاركة الأصلية كتبت بواسطة: YasserKhalil
دالة رائعة أخي الغالي إسلام
بالنسبة للملف المرفق هو نفسه ملفك ولكن اجعل الأسماء تبدأ من أول خلية A1 واحذف التنسيق الشرطي .. 142

تمام طبقت الكود ، ابداع كعادتك biggrin2


أثارت هذه المشاركة إعجاب: YasserKhalil،




27-05-2019 12:29 مساء
مشاهدة مشاركة منفردة [12]
Eslam Abdullah
menu_open
مشرف على لغات برمجة آخرى
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 03-10-2017
رقم العضوية : 852
المشاركات : 1440
الجنس : ذكر
تاريخ الميلاد : 1-9-1995
الدعوات : 4
يتابعهم : 0
يتابعونه : 74
قوة السمعة : 9048
الاعجاب : 195
 offline 
look/images/icons/i1.gif دالة معرفة لتأكيد تشابه النصوص
المشاركة الأصلية كتبت بواسطة: مالك ماريه
بارك الله فيكم جميعا استاذى الغالى استاذ ياسر واخى الحبيب الاستاذ اسلام عبدالله وجزاكم الله خير

وبارك الله فيك أخى العزيز ، مشكور مرورك الكريم ، كل عام وانت بخير







الكلمات الدلالية
النصوص ، تشابه ، لتأكيد ، معرفة ، دالة ،


 







اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.



الساعة الآن 10:19 مساء

أعلن هنا
أعلن هنا
أعلن هنا