logo

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
Hatem Eissa hassona229-- لا تميز خلال هذه الفترة لا تميز خلال هذه الفترة لا تميز خلال هذه الفترة اكسيل مشاريع جاهزه



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





25-05-2019 12:23 مساءً
معلومات الكاتب ▼
تاريخ الإنضمام : 03-10-2017
رقم العضوية : 852
المشاركات : 1580
الدولة : مصر
الجنس :
تاريخ الميلاد : 1-9-1995
الدعوات : 5
قوة السمعة : 10861
الاعجاب : 6
موقعي : زيارة موقعي

بســـــم الله والحـمد للـــه والصـلاة والسـلام علـى رسـول الله
أهلا ومرحبا بكم أخوانى الكرام من جديد
ومعكم عريف مجند من القوات المسلحه فى أجازة جديده من جديد الجديد 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 باراميتر
الأول هو النطاق المراد اختبار تكرار تشابه النص بها
والثانى هى الخلية المراد اختبار تكرارها بالتشابه داخل النطاق المحدد

ويمكن استخدام تلك القيم فى التنسيق الشرطى
لتظليل النصوص المتشابهه بنفس الطريقة
وكـــود الـدالـة هــو :-

CODE
Function AlsaqrSimilar(rng As Range, cr As Variant) As Boolean
'Developer: Eslam Abdullah
Dim serial%, a%, i%, adrs$, str$, chk As Boolean, cell As Variant
adrs = cr.address: cr = Application.Trim(cr)
    For Each cell In rng
        If cell.address <> adrs Then
            cell = Application.Trim(cell): str = cell: a = 0
            For i = 1 To Len(cr)
                serial = InStr(str, Mid(cr, 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 a / (Application.Max(Len(cell), Len(cr)) + (cell & cr = "")) > 0.7 Then AlsaqrSimilar = True: Exit Function
        End If
    Next cell
End Function



كـــان معكم أخـوكـم فـى الله إســـلام عبدالله
لا تنسونا مـن صالح دعائكم 81
 
 





look/images/icons/i1.gif دالة معرفة لتأكيد تشابه النصوص
  25-05-2019 01:34 مساءً   [1]
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 1
المشاركات : 1332
الجنس :
الدعوات : 13
قوة السمعة : 10066
الاعجاب : 67
موقعي : زيارة موقعي
منور ياغالي ايه الشغل الحلو داجزاكم الله خيرا2015_1418710703_134



توقيع :Yasser Elaraby
663013020

look/images/icons/i1.gif دالة معرفة لتأكيد تشابه النصوص
  25-05-2019 02:17 مساءً   [2]
معلومات الكاتب ▼
تاريخ الإنضمام : 03-10-2017
رقم العضوية : 852
المشاركات : 1580
الدولة : مصر
الجنس :
تاريخ الميلاد : 1-9-1995
الدعوات : 5
قوة السمعة : 10861
الاعجاب : 6
موقعي : زيارة موقعي
ميغسى بوكو أغالى هذا بعض ما عندكم biggrin2




look/images/icons/i1.gif دالة معرفة لتأكيد تشابه النصوص
  26-05-2019 12:14 صباحاً   [3]
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10529
الجنس :
تاريخ الميلاد : 1-10-1978
الدعوات : 24
قوة السمعة : 36759
الاعجاب : 186
الله ينور يا سمسم .. بارك الله فيك وجزيت خيراًوكل عام وأنت بخير




look/images/icons/i1.gif دالة معرفة لتأكيد تشابه النصوص
  26-05-2019 12:41 صباحاً   [4]
معلومات الكاتب ▼
تاريخ الإنضمام : 03-10-2017
رقم العضوية : 852
المشاركات : 1580
الدولة : مصر
الجنس :
تاريخ الميلاد : 1-9-1995
الدعوات : 5
قوة السمعة : 10861
الاعجاب : 6
موقعي : زيارة موقعي
مشكور لمرورك الكريم أستاذى الغالى ياسركل عام وانت بألف خير




look/images/icons/i1.gif دالة معرفة لتأكيد تشابه النصوص
  26-05-2019 08:00 صباحاً   [5]
معلومات الكاتب ▼
تاريخ الإنضمام : 24-08-2017
رقم العضوية : 80
المشاركات : 723
الجنس :
تاريخ الميلاد : 14-5-1965
الدعوات : 2
قوة السمعة : 3892
الاعجاب : 16
890264ما شاء الله لا قوة إلا باللهأحسنتم أحسن الله إليكم123



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

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


look/images/icons/i1.gif دالة معرفة لتأكيد تشابه النصوص
  26-05-2019 09:42 صباحاً   [6]
معلومات الكاتب ▼
تاريخ الإنضمام : 20-11-2017
رقم العضوية : 1757
المشاركات : 1765
الدولة : مصر
الجنس :
الدعوات : 2
قوة السمعة : 9685
الاعجاب : 25
رائع استاذ اسلام بارك الله فيك وجعله الله فى ميزان حسناتك وزادك الله من فضله



توقيع :ali mohamed ali


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

look/images/icons/i1.gif دالة معرفة لتأكيد تشابه النصوص
  26-05-2019 11:39 صباحاً   [7]
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10529
الجنس :
تاريخ الميلاد : 1-10-1978
الدعوات : 24
قوة السمعة : 36759
الاعجاب : 186
بفرض أن الأسماء أو الجمل المراد استخراج المتشابه منها تبدأ في الخلية 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 = 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




look/images/icons/i1.gif دالة معرفة لتأكيد تشابه النصوص
  27-05-2019 03:08 صباحاً   [8]
معلومات الكاتب ▼
تاريخ الإنضمام : 03-10-2017
رقم العضوية : 852
المشاركات : 1580
الدولة : مصر
الجنس :
تاريخ الميلاد : 1-9-1995
الدعوات : 5
قوة السمعة : 10861
الاعجاب : 6
موقعي : زيارة موقعي
عمل رائع أستاذى الغالىانا بس حاولت اطبق اول اجراء باسم test مش راضى ممكن ملف عمل بالتطبيقواثراء للموضوع اكثر اليك بدالة معرفة أخرى لإستخراج نسبة التشابه بين نصين
CODE
Function SimilarEA(text1 As String, text2 As String) As Double'Developer: Eslam AbdullahDim 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
مثال على الدالة
CODE
Sub Alsaqr_test()Const text1 = "اسلام عبدالعزيز"Const text2 = "اسلام عبدالله"MsgBox "The similarity ratio is " & FormatPercent(SimilarEA(text1, text2), 0)End Sub
[b][/b]




look/images/icons/i1.gif دالة معرفة لتأكيد تشابه النصوص
  27-05-2019 08:56 صباحاً   [9]
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10529
الجنس :
تاريخ الميلاد : 1-10-1978
الدعوات : 24
قوة السمعة : 36759
الاعجاب : 186
دالة رائعة أخي الغالي إسلامبالنسبة للملف المرفق هو نفسه ملفك ولكن اجعل الأسماء تبدأ من أول خلية A1 واحذف التنسيق الشرطي .. 142




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




look/images/icons/i1.gif دالة معرفة لتأكيد تشابه النصوص
  27-05-2019 12:28 مساءً   [11]
معلومات الكاتب ▼
تاريخ الإنضمام : 03-10-2017
رقم العضوية : 852
المشاركات : 1580
الدولة : مصر
الجنس :
تاريخ الميلاد : 1-9-1995
الدعوات : 5
قوة السمعة : 10861
الاعجاب : 6
موقعي : زيارة موقعي
المشاركة الأصلية كتبت بواسطة: YasserKhalil دالة رائعة أخي الغالي إسلامبالنسبة للملف المرفق هو نفسه ملفك ولكن اجعل الأسماء تبدأ من أول خلية A1 واحذف التنسيق الشرطي .. 142
تمام طبقت الكود ، ابداع كعادتك biggrin2




look/images/icons/i1.gif دالة معرفة لتأكيد تشابه النصوص
  27-05-2019 12:29 مساءً   [12]
معلومات الكاتب ▼
تاريخ الإنضمام : 03-10-2017
رقم العضوية : 852
المشاركات : 1580
الدولة : مصر
الجنس :
تاريخ الميلاد : 1-9-1995
الدعوات : 5
قوة السمعة : 10861
الاعجاب : 6
موقعي : زيارة موقعي
المشاركة الأصلية كتبت بواسطة: مالك ماريه بارك الله فيكم جميعا استاذى الغالى استاذ ياسر واخى الحبيب الاستاذ اسلام عبدالله وجزاكم الله خير
وبارك الله فيك أخى العزيز ، مشكور مرورك الكريم ، كل عام وانت بخير




اضافة رد جديد اضافة موضوع جديد
الصفحة 2 من 2 < 1 2 >





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









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

الساعة الآن 12:08 AM