استخراج الأرقام المتشابهة والأرقام المختلفة من أوراق العمل المختلفة

[ammar444]

السلام عليكم

رمضان كريم واحب ان اشكر كل العاملين على هذا الموقع الرائع وربي يوفقكم ومن افضل الى افضل.

عندي اربع شيتات اكسل كل شيت يحتوي على مجموعة ارقام هواتف وتوجد في هذه الشيتات الاربعة ارقام هواتف متشابهة ومبعثرة في التسلسل محتاج شيت خامس يعطي نتيجة بحيث يعطيني الارقام المتشابهة في هذه الشيتات الاربعة على حدة والمختلفة على حدة اخرى ..

واكون شاكرا لكم

لا استطيع ان ارفع الملف لكونه موجود فيه ارقام هواتف تحياتي لكم

[ياسر خليل أبو البراء]

ارفق نموذج مشابه

قم بوضع بعض الأرقام الوهمية للإطلاع على الملف ومعرفة شكل النتائج المطلوبة بدقة

تقبل تحياتي

[ammar444]

اخي بامكانك ان تضع ارقام انت

اناةبحاجة الى ورقة عمل بحيث يحتوي شيت رقم 1 في العمود a ارقام من 1 الى ١٠٠٠ مثلا وشيت رقم ٢ يحتوي على ارقام من ٥٠٠ الى ١٥٠٠ مثلا وشيت رقم ٣ يحتوي على ارقام من ٧٠٠ الى ٢٠٠٠ وشيت رقم ٤ يحتوي على ارقام من ٨٠٠ الى ١٠٠ النتيجة شيت رقم ٥ يطلعو الارقام المتشابهة من هذه الشيتات على حدة والارقام المختلفة على حدة اخرى

اعتقد اصبح الموضوع واضح اكثر

[ياسر خليل أبو البراء]

أخي الكريم أبو تيم

لن أزيد في كلماتي .. قدر وقت الآخرين ليقدروك (حكمة من شخص مش حكيم)

أعتقد أن الأمر لن يكون بالصعوبة في إرفاق ملفك حتى تكون الأمور واضحة كالشمس ..

ويا حبذا لو كان هناك نتائج بالشكل المتوقع ولو بأمثلة بسيطة لتتضح الفكرة

 

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

 

تقبل تحياتي وكل عام وأنت بخير

[ammar444]

السلام عليكم اخي العزيز

تقبل الله صيامكم وعيد مبارك

عفوا كيف يتم رفع الملف الى المنتدى

ولكم جزيل الشكر

[ياسر خليل أبو البراء]

راجع رابط موضوع التوجيهات في الموضوعات المثبتة في المنتدى

من هنا

 

لتعرف كيفية التعامل مع المنتدى

تقبل الله منا ومنكم

[ammar444]

الملف المرفق يوضح ما هو مطلوب واكون ممنون لكم وربي يوفقكم 

اتمنى ان تكون القاعدة ثابتة اي بمعنى انه بامكاني ان اغير الارقام الموجودة للحصول على نتائج جديدة

sheet.zip

[ياسر خليل أبو البراء]

أخي الكريم أبو تيم

هل الأرقام تبدأ في الخلية A2 في العمود الأول في أوراق العمل الأربعة ..

سؤال آخر : هل الأرقام في ورقة العمل الواحدة مكررة أم أنها غير مكررة في ورقة العمل الواحدة؟

[ياسر خليل أبو البراء]

عموماً إليك الكود التالي عله يفي بالغرض إن شاء المولى

Sub Test()
    Dim Coll As New Collection, ArrSheet, ArrTemp, ArrHolder, ArrOut1, ArrOut2
    Dim I As Long, J As Long, P As Long, P1 As Long, P2 As Long, Str1 As String

    ArrSheet = Array(Sheets("مباع"), Sheets("مفعل"), Sheets("active"), Sheets("راجع"))
    ReDim ArrHolder(1 To Rows.Count, 1 To (UBound(ArrSheet) + 2))
    ReDim ArrOut1(1 To Rows.Count, 1 To 1)
    ReDim ArrOut2(1 To Rows.Count, 1 To 1)

    For J = LBound(ArrSheet) To UBound(ArrSheet)
        ArrTemp = ArrSheet(J).Range("A2").CurrentRegion.Columns(1).Value
        On Error Resume Next
        For I = 1 To UBound(ArrTemp, 1)
            Str1 = CStr(ArrTemp(I, 1))
            Coll.Add Key:=Str1, Item:=Coll.Count + 1
            P = Coll(Str1)
            ArrHolder(P, 1) = ArrTemp(I, 1)
            ArrHolder(P, J + 2) = ArrHolder(P, J + 2) + 1
        Next I
        On Error GoTo 0
    Next J

    For I = 1 To Coll.Count
        P = 0
        For J = 2 To UBound(ArrHolder, 2)
            P = P + Sgn(ArrHolder(I, J))
        Next J
        If (P = UBound(ArrSheet) + 1) Then
            P1 = P1 + 1
            ArrOut1(P1, 1) = ArrHolder(I, 1)
        Else
            P2 = P2 + 1
            ArrOut2(P2, 1) = ArrHolder(I, 1)
        End If
    Next I

    With Sheets("النتيجة المطلوبة")
        .Range("A2").Resize(P1).Value = ArrOut1
        .Range("B2").Resize(P2).Value = ArrOut2
    End With
End Sub

سيتم استخراج الأرقام المتشابهة في كل أوراق العمل الأربعة معاً في العمود الأول أما الأرقام التي لم تحقق الشرط ستكون في العمود الثاني في ورقة العمل الأخيرة

 

لا تنسى أن تحدد أفضل إجابة وأن تضغط على كلمة "أعجبني هذا" في حالة أن أعجبك الحل

 

تقبل تحياتي

Similar Data In Multi Sheets YasserKhalil.rar

[ammar444]

جزاك الله الف خير لكن الملف او ما اشغلة يطلعلي خيار تمكين المحتوى واختار تمكين المحتوى بعدها يفتح الشيت واذهب الى ورقة عمل موجودة اسمها النتيجة المطلوبة يظهر فقط حقول فارغة لا توجد ارقام وعبارة توكل على الله 

[ياسر خليل أبو البراء]

أخي الكريم

قم بمشاهدة الفيديو التالي لتمكين محتوى الماكرو ..بعدها انقر على زر الأمر "توكل على الله" لتنفيذ أسطر الكود وتنفيذ المطلوب إن شاء الله

[ammar444]

اتمنى منك ان تكون قاعدة ثابتة بحيث تكون اساس لكي اعمل على ارقام اخرى 

[ammar444]

انا جدا اشكرك عملت مثل ما موجود في الفيديو ولكن عن الضغط على زر الامر ( توكل على الله ) يطلع امر run-time errore 9

[ياسر خليل أبو البراء]

انقر على كلمة Debug وشوف السطر الملون باللون الأصفر ..

الكود يعمل عندي بشكل جيد

يمكن للأعضاء تجربة الكود وإبداء آرائهم ...

[ammar444]

العفو استاذ ياسر بعد ما تظهر هاي العبارة زر continue  لا استطيع ضغطه لكونه غير مفعل وزر end للنهاية وزر Debug موجود عند ظغطه يظهر الكود واللون الاصفر 

انا اي زر اضغط لظهور النتيجة

[ياسر خليل أبو البراء]

السطر ذو اللون الأصفر يعني وجود خطأ .. يرجى إدراج هذا السطر في المشاركة الخاصة بك للإطلاع عليه

ويمكن لأحد الأخوة الذين جربوا الكود أن يعلمونا بالنتيجة لمعرفة عمل الكود من عدمه لأن الكود يعمل معي بدون مشاكل

[ammar444]

الملف المرفق يوضح السطر الاصفر الذي يظهر

Untitled.rar

[ammar444]

شكرا جزيلا لك تم حل المشكلة وهي اعادة تسمية اوراق العمل الى اللغة الانكليزية 

ربي يوفقك 

بس حبيت استفسر هل هذه قاعدة ثابتة بحيث بامكاني تغيير الارقام واضافة غيرها

[ياسر خليل أبو البراء]

لم أفهم استفسارك بشكل جيد

ولكن قم بالتعديل على الأوراق ونفذ الأمر وشوف النتائج ... النتائج متجددة كلما نفذت الكود

تقبل تحياتي

[محمد حسن المحمد]

 

عموماً إليك الكود التالي عله يفي بالغرض إن شاء المولى

Sub Test()
    Dim Coll As New Collection, ArrSheet, ArrTemp, ArrHolder, ArrOut1, ArrOut2
    Dim I As Long, J As Long, P As Long, P1 As Long, P2 As Long, Str1 As String

    ArrSheet = Array(Sheets("مباع"), Sheets("مفعل"), Sheets("active"), Sheets("راجع"))
    ReDim ArrHolder(1 To Rows.Count, 1 To (UBound(ArrSheet) + 2))
    ReDim ArrOut1(1 To Rows.Count, 1 To 1)
    ReDim ArrOut2(1 To Rows.Count, 1 To 1)

    For J = LBound(ArrSheet) To UBound(ArrSheet)
        ArrTemp = ArrSheet(J).Range("A2").CurrentRegion.Columns(1).Value
        On Error Resume Next
        For I = 1 To UBound(ArrTemp, 1)
            Str1 = CStr(ArrTemp(I, 1))
            Coll.Add Key:=Str1, Item:=Coll.Count + 1
            P = Coll(Str1)
            ArrHolder(P, 1) = ArrTemp(I, 1)
            ArrHolder(P, J + 2) = ArrHolder(P, J + 2) + 1
        Next I
        On Error GoTo 0
    Next J

    For I = 1 To Coll.Count
        P = 0
        For J = 2 To UBound(ArrHolder, 2)
            P = P + Sgn(ArrHolder(I, J))
        Next J
        If (P = UBound(ArrSheet) + 1) Then
            P1 = P1 + 1
            ArrOut1(P1, 1) = ArrHolder(I, 1)
        Else
            P2 = P2 + 1
            ArrOut2(P2, 1) = ArrHolder(I, 1)
        End If
    Next I

    With Sheets("النتيجة المطلوبة")
        .Range("A2").Resize(P1).Value = ArrOut1
        .Range("B2").Resize(P2).Value = ArrOut2
    End With
End Sub

سيتم استخراج الأرقام المتشابهة في كل أوراق العمل الأربعة معاً في العمود الأول أما الأرقام التي لم تحقق الشرط ستكون في العمود الثاني في ورقة العمل الأخيرة

 

لا تنسى أن تحدد أفضل إجابة وأن تضغط على كلمة "أعجبني هذا" في حالة أن أعجبك الحل

 

تقبل تحياتي

 

ما شاء الله بارك الله ..لا قوة إلا بالله..

[ياسر خليل أبو البراء]

مشكور على مرورك العطر بالموضوع أخي وحبيبي في الله أبو يوسف

بارك الله فيك وجزيت خير الجزاء

[ammar444]

الاخ ياسر جزاك الله الف خير وبارك الله بيك

طلب صغير اخر

هل بامكانك ان تكون في النتيجة عمود ثالث يحقق الشرط الاول والثاني فقط ( مباع مع المفعل ) فقط

ربي يحفظكم