بحث متقدم - سرعة عالية ومرونة باستخدام المصفوفات

[ياسر العربى]

بسم الله الرحمن الرحيم 

 

 اقدم لكم  كود بحث متقدم

 

كود بحث متقدم  يفوق معظم أنواع  البحث بالاعتماد على المصفوفات 
 

لضمان كفاءة عالية للبحث وسرعة جلب البيانات 
 

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

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

الكود المستخدم داخل الملف 

Sub Yasser_Serch()
    Dim myArray, lr, X, targt, targtN
    Dim SERCH As Worksheet, DATA As Worksheet
    '____________________________________________
    Set DATA = Worksheets("Sheet2")    'اسم شيت قاعدة البيانات
    Set SERCH = Worksheets("Sheet1")    'اسم الشيت الخاص بالبحث
    '____________________________________________
    lr = DATA.Cells(Rows.Count, 1).End(xlUp).Row    'اخر صف به بيانات
    SERCH.Range("A4:J" & SERCH.Cells(Rows.Count, 4).End(xlUp).Row + 1).ClearContents    'مسح نطاق البحث القديم
    targt = SERCH.Range("e1").Value    'خلية البحث
    targtN = Application.WorksheetFunction.Match(SERCH.Range("D1"), SERCH.Range("A3:J3"), 0)    'دالة لايجاد رقم عمود البحث
    myArray = DATA.Range("A2:J" & lr + 1)    'نطاق قاعدةالبيانات الذي سيتم البحث فيه
    '____________________________________________
    ReDim Y(1 To lr, 1 To 10)
    For X = 1 To lr
        If targt = "" Then Exit Sub
        If myArray(X, targtN) Like targt & "*" Then
            rw = rw + 1
            Y(rw, 1) = myArray(X, 1): Y(rw, 6) = myArray(X, 6)
            Y(rw, 2) = myArray(X, 2): Y(rw, 7) = myArray(X, 7)
            Y(rw, 3) = myArray(X, 3): Y(rw, 8) = myArray(X, 8)
            Y(rw, 4) = myArray(X, 4): Y(rw, 9) = myArray(X, 9)
            Y(rw, 5) = myArray(X, 5): Y(rw, 10) = myArray(X, 10)
        End If
    Next X
    If rw > 0 Then SERCH.Cells(Rows.Count, 1).End(xlUp)(2, 1).Resize(rw, 10).Value = Y()
End Sub

لتحميل الملف اضغط هنا


اعداد /  ياسر العربي

تقبلو تحياتي

[جلال الجمال_ابو أدهم]

ياسر العربى

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

[saad abed]

ياسر العربى

اخى ياسر

شيء جديد فعلها عبدالله باقشير بالبحث في اللست

جزاك الله خيرا اخى

الله عليك

 

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

بارك الله فيك أخي الغالي ياسر العربي وجعل ما تقدمه في ميزان حسناتك يوم القيامة

تقبل وافر تقديري واحترامي

[احمد 505]

ماشاء الله تبارك الله

دائما مبدع أستاذ ياسر

اشكرك يالحبيب

[محي الدين ابو البشر]

السلام عليكم

يارك الله

وادامك ذخراً

[ناصر سعيد]

خليفه العالم العلامه غبد الله باقشير المحترم ياسر العربي

يحفظك ربنا ويصونك

[أبو حنــــين]

السلام عليكم

اخي ياسر العربي : جزاك الله خيرا 

[عاطف عبد العليم محمد]

استاذنا العزيز / ياسر العربي  

ممكن مثال البحث يكون على شرطين  مثلا ( الأسم ) والتاريخ  والتاريخ يكون  مثلا بين 2016/1/01 و 2016/10/10

وجزاك الله خيرا 

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

أخي الكريم عاطف

هذا الموضوع أريد التعامل معه ولكن يلزمني ملف مصمم بطريقة احترافية لكي يكون مثال واضح للمطلوب ..

قم بتصميم ملفك الذي هو بمثابة قاعدة البيانات ..حدد عمود التاريخ وضع تاريخ البداية في خلية ، وتاريخ النهاية في خلية ، وضع الشروط في الخلايا التي ترغبها ..

فقط عليك التصميم (ولكن بشكل احترافي ..ابتعد عن التنسيقات العالية فقط قم بتنسيق البيانات بشكل بسيط ومنظم .. اجعل العناوين واضحة .. وضح شكل المخرجات : هل تريد المخرجات لجميع الأعمدة أم أن هناك أعمدة ستقوم باستثنائها ؟)
وإن شاء الله إذا تيسر لي الوقت سأقوم بطرح موضوع بهذا الخصوص

تقبل تحياتي

[عاطف عبد العليم محمد]

استاذنا ياسر  سأرفق إن شاء الله نموذج مصغر للملف الذي أعمل عليه  ( ولعله يفيد غيري ) وأرجو منك العمل عليه

وفقكم الله 

[سليم حاصبيا]

ربما يكون هذا الكود (المرفق)اسرع قليلاً

 

SERCH_ARRY salim.rar

[محمد عبدالله المسعودي]

الاخ ياسر العربي عمل روعة . جزاكم الله خيرا

 

[ياسر العربى]

مشكورين جميعا اخواني لمروركم الكريم

تقبلو خالص تحياتي

 

 

اما بخصوص البحث بشروط تفضلو التعديل بحث باي شرط الى شرط التاريخ كما طلب الاخ عاطف

وشكرا

 

 

SERCH_ARRY_YASSER_ELARABY1.rar

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

السلام عليكم ورحمة الله وبركاته

أخي الحبيب أبو أسيل

أنت كعادتك مبدع ...أحسنت جزاك الله خيراً...

شكراً جزيلاً على اللمسات الرائعة على الأكواد

والتوضيحات المرفقة بها.

والسلام عليكم ورحمة الله وبركاته

[ياسر العربى]

اخي الحبيب ابو يوسف حمدا لله على سلامتك طولت الغيبة

نتمنى ان تكون في تمام الصحة والعافية انت وجميع العائلة

مشكور على كلماتك الجميلة

تقبل خالص تقديري

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

12 دقائق مضت, ياسر العربى said:

اخي الحبيب او يوسف حمدا لله على سلامتك طولت الغيبة

نتمنى ان تكون في تمام الصحة والعافية انت وجميع العائلة

مشكور على كلماتك الجميلة

تقبل خالص تقديري

السلام عليكم ورحمة الله وبركاته

أخي الحبيب أبو أسيل

أسأل الله تعالى أن يسلمكم من كل سوء..

اعلم يقيناً أنني لا أستغني عن علمكم وأدبكم والانتساب إلى هذا الطود الشامخ ولكن الظروف ...رمت بي بعيداً عن التواصل معكم

بارك الله بكم وجزاكم الله خيراً

والسلام عليكم ورحمة الله وبركاته

تم تعديل أكتوبر 7, 2016 بواسطه محمد حسن المحمد

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

عمل رائع من عملاقة الاكسيل

تم تعديل أكتوبر 7, 2016 بواسطه احمد السيد سليمان

[ناصر سعيد]

الاساتذه العظام

اريد تفعيل الكود الرائع للاستاذ ياسر العربي

او الكود المتميز للاستاذ سليم

بارك الله فيهما

في ملف به الرؤوس بها خلايا مدمجه

 

[ياسر العربى]

اخي الكريم ناصر يرجى ارفاق المثال للتوضيح

وشكرا

[ناصر سعيد]

تفضل اخي العبقري ياسر العربي

 

فلتره.rar

[ياسر العربى]

تفضل اخي الكريم طلبك
 

 

Serch_Yasser.rar

[ناصر سعيد]

فضلك الله بالجنه ياخليفه الغلامه عبد الله باقشير

[قلم-الاكسل(عبدالعزيز)]

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

[ناصر سعيد]

Sub Yasser_Serch()
''هذا الكود للعبقري ياسر العربي حفظه الله
'' تم هذا الكود بتاريخ 8 / 10/ 2016
''الهدف من الكود هو فلترة البيانات
''شرح الكود
''
    Dim myArray, lr, X, targt, targt1, targt2, targtN
    Dim SERCH As Worksheet, DATA As Worksheet
    '____________________________________________
    Set DATA = Worksheets("رصد الترم الثانى")    'اسم شيت قاعدة البيانات
    Set SERCH = Worksheets("الحاله")    'اسم الشيت الخاص بالبحث
    '____________________________________________
    lr = DATA.Cells(Rows.Count, 2).End(xlUp).Row + 2  'اخر صف به بيانات
    SERCH.Range("A10:CX" & SERCH.Cells(Rows.Count, 2).End(xlUp).Row + 1).ClearContents    'مسح نطاق البحث القديم
    targt = SERCH.Range("e2").Value    'خلية البحث
    myArray = DATA.Range("A7:CX" & lr)     'نطاق قاعدةالبيانات الذي سيتم البحث فيه
    '____________________________________________
    ReDim Y(1 To lr, 1 To 102)
    For X = 1 To lr - 6
        If targt = "" Then Exit Sub
        If myArray(X, 101) Like targt & "*" Then
            rw = rw + 1
            For ww = 1 To 102
                Y(rw, ww) = myArray(X, ww)
            Next ww
        End If
Next X
If rw > 0 Then SERCH.Cells(Rows.Count, 1).End(xlUp)(2, 1).Resize(rw, 102).Value = Y()
End Sub

الاستاذ ياسر العربي

السلام عليكم ورحمة الله وبركاته

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

جزاك الله خيرا