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

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

نورت المنتدي أخي ياسر ، غبت طويلا ان شاء الله خير

الحمد لله على العودة 

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

السلام عليكم  أخي أبو البراء 

اولا شكرا على الرد

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

ثالثا حاولت ان اكتب لك على مدونتك فلم اعرف

فقد حملت الملف لأستفاد منه ومن شرحكم ولكنه لم يعمل معي وجائتني رسالة بوجود محتوى غير قابل للقراءة لا ادري هل هذا السبب ام غيره    ..................  ( بعد كتابة ذلك عرفت كيف استخدم ملفكم ) 

و خدمة أخرى لو تكرمت  في كود أخونا ياسر العربي

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
        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()

اريد بدلا من ان تكون النتائج بدلا من بداية العمود رقم 1  تكون من بداية العمود رقم 12 

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

تم تعديل نوفمبر 15, 2016 بواسطه عاطف عبد العليم محمد
( بعد كتابة ذلك عرفت كيف استخدم ملفكم ) 

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

هل تقصد هكذا!

SERCH_ARRY_YASSER_ELARABY - Copy.rar

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

الاخ الكريم / ياسر العربي 

جزاك الله خيرا على تفضلك بالرد

والحمد الله استطعت استخدام كود الاخ / ابو البراء واستطعت التعديل فيه حسب ما يناسبني

و الآن لو تتفضلا اريد تعديل تحديد صفحة النتائج لتكون الصفحة النشطة بدون تسميتها

لاني سأستخدم نفس الكود في اكثر من صفحة وقد استخدمت الاتي ولم يفلح

Set wsResult = ActiveWorkbook    

وايضا لم يفلح

 Set wsResult = thisWorkbook

            فهل من حل ؟ بارك الله فيكما

 

 

وجدت الحل الحمد لله Set wsResult = ThisWorkbook.ActiveSheet

 

تم تعديل نوفمبر 16, 2016 بواسطه عاطف عبد العليم محمد

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

السلام عليكم 

الأخ / ابو البراء

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

فمثلا في مثالك عند البحث عن ناجح يظهر عمود ناجح ولا فائدة منه 

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

فلو كانت مصفوفة البحث مثلا من a الى j  تكون النتائج المرحلة تبدء من b الى j

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

 

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

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

 

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

تحياتي

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

ياسر العربى

المنتدى نور يا كبير

تحياتى يا غالى

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

بنورك ياغالي

المنتدى منور بالموجودين وبكم اخي الكريم جلال الجمال
تحياتي لك

[إبراهيم ابوليله]

اخى ابو العربى

وحشنا والله

الكود جميل جدا

بجد اقف دائما امام اكوادكم

وانحنى لها اكراما وتعظيما

لها

كل التحيه والتقدير لشخصك الجميل

......................................................

بصراحه بردو موضوع المصفوفات ده كبير قوى

بصراحه نفسى افهمو كويس

ادينى بحاول

.................................

ياريت لو توسع نطاق البحث شويه

اه يبقى بناء على شرطىن

مثلا الشرط الثانى يبقى انه يكون محاسب

.........................................................

وياريت لو تعمل ده بردو فى فورم بحث

...................................................

ده طبعا علشان الناس تستفيد اكتر

..........................................

تقبل تحياتى

 

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

ياسر العربى

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

و يرجى رفع الملف النهائى بعد اجراء جميع التعديلات على الكود الذى تم خلال المشاركات
و هو ملفين ملف بحث الاصلى و الثانى ملف بحث بين تاريخين

لانى بينى و بينك انا تهت بين الملفات فى المشاركات
تحياتى

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

باذن الله اقوم بعمل امثلة متعددة على الكود

من ترحيل وبحث واستدعاء داخل الشيت او داخل فورم بحث

اخي الكريم ابراهيم ابو ليله

اخي الكريم جلال الجمال

تحياتي لكم

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

ياسر العربى

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

[ناصر سعيد]

شرح الحبيب الغالي ياسر للكود المميز

http://up.top4top.net/downloadf-3295bbxd1-rar.html

 

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

[ناصر سعيد]

المحترم  العبقري ياسر ابو العربي

اريد استدعاء بيانات في  كشف الناجحين والراسبين

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

 

 

ترحيل الدور التاني5.rar

تم تعديل نوفمبر 25, 2016 بواسطه ناصر سعيد
تكبير الخط

[ناصر سعيد]

يتم الاستدعاء ولكن من الصف السابق للصف المرغوب فيه يعني انا عايز يبدا من الصف ال7 ولكن الاستدعاء يبدا من الصف 6

[altarafalzahabi]

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

 

https://www.officena.net/ib/applications/core/interface/file/attachment.php?id=120135

كلمة المرور : 5310

[ناصر سعيد]

Option Explicit

Sub Araby_Search()
    'تعريف المتغير لورقة العمل التي تحتوي على البيانات الخام
    Dim wsData As Worksheet

    'تعريف المتغير لورقة العمـل المطلـوب إظهـار النتائـج بها
    Dim wsResult As Worksheet

    'تعريف المتغير ليحمل قيم المصفـوفة للبيانات الخـام
    Dim Arr As Variant

    'تعريف المتغير ليحمل قيم المصفوفة للنتائج المطلوبة
    Dim Temp As Variant

    'تعريـف المتغير من النـوع النصي ليحمـل قيمة أو نص البحث
    'أي الكلمة المطلوب البحث عنها يتم تخزينها في هذا المتغير
    Dim strSearch As String
    
    'تعريف المتغير وسيستخدم في الحلقة التكرارية لصفوف المصفوفة
    Dim I As Long
    
    'تعريف المتغير وسيستخدم في الحلقة التكرارية لأعمدة المصفوفة
    Dim J As Long
    
    'تعريف المتغير وسيستخدم في مصفوفة النتائج لزيادة مقدار الصفوف بمقدار واحد
    Dim P As Long
    
    'تعيين قيمة للمتغير ليساوي ورقة العمل التي تحتوي
    '[Data] على البيانات الخام المطلوب معالجتها والمسماة
    Set wsData = Worksheets("Data")

    'تعيين قيمة للمتغير ليساوي ورقة العمل التي تريد إظهار
    '[G2] النتائج بها بمجرد إدخال قيمة أو نص محدد في الخلية
    Set wsResult = Worksheets("Result")
    
    'مسح النطاق الذي توضع فيه النتائج استعداداً لوضع النتائج الجديدة
    wsResult.Range("A8:N10000").ClearContents
    
    '[G2] تعيين قيمة للمتغير ليساوي قيمة الخلية
    'وهي الخلية التي ستوضع فيها نص الكلمة المطلوب البحث عنها
    strSearch = wsResult.Range("G2").Value
    
    'تعيين قيمـة للمتغير ليحمل قيم النطاق بالكامل للبيانات الخام
    ' وذلك [Data] حيث أن مصـدر البيانات الخام ورقة العمل المسماة
    'عند [N] وينتهي في العمود [A5] في النطاق الذي يبدأ من الخلية
    '[&] آخـر صف به بيانات ، ويتم تحديده عن طريـق الجزء بعد علامـة
    Arr = wsData.Range("A5:N" & wsData.Cells(Rows.Count, 1).End(xlUp).Row).Value
    
    'والتي ستحمل قيم النتائج [Temp] إعادة تعيين أبعاد المصفوفة المسماة
    '[Arr] وتكون بنفس أبعاد المصفوفة التي تحمل البيانات الخام والمسماة
    'سنعتبر المصفوفة أشبـه بالصفـوف والأعمدة حيث الرقـم 1 يمثـل الصفـوف
    'بإرجاع أكبر قيمة [UBound]بينما الرقم 2 يمثل الأعمدة ، وتقوم الكلمة
    'أبعاد المصفوفة في هذه الحالة >>
    '-------------------------------
    'البعد الأول سيكون من 1 إلى أكبر قيمة للصفوف
    'البعد الثاني سيكون من 1 إلى أكبر قيمة للأعمدة
    ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    
    'حلقة تكرارية من الصف الأول للمصفوفة إلى آخر صف بها
    For I = 1 To UBound(Arr, 1)
    
        'إذا كان النص المطلوب البحث عنه فارغ يتم الخروج من تنفيذ الكود
        If strSearch = "" Then Exit Sub
        
        'هذا السطر هو أهم سطر بالكود حيث هو الشرط الذي من خلاله
        'والشرط [Temp] ستوضع النتائج في مصفوفة النتائج المسماة
        'هـو تطابق قيمة المصفوفة في صف الحلقة في العمود رقم 14
        'حيث يمثـل الرقم 14 العمود داخـل مصفوفة البيانات الخام
        '[strSearch] يتـم اختبـار التطابـق مع نـص البحث المسمى
        If Arr(I, 14) Like "*" & strSearch & "*" Then
            
            'زيادة مقدار المتغير بمقدار 1
            'فائدة المتغير هنا هو أنه مع كل حلقة تكرارية
            'إذا تحقق الشرط فقط يزيد المتغير بمقدار واحد
            'ليمثل هذا المتغير صفوف مصفوفة النتائج الجديدة
            P = P + 1
            
            'حلقة تكرارية داخلية من العمود الأول للمصفوفة إلى آخر عمود بها
            For J = 1 To UBound(Arr, 2)
                
                'تعبئـة مصفـوفة النتائـج بالبيانات مـن مصفوفة البيانات الخام
                '[Temp]مثـال لتتضح صورة كيفية تعبئة المصفوفة الجديدة المسماة
                'في أول حلقـة سيكون مقداره 1 ويمثل أول صف [P] المتغيـر المسمى
                'أول صف هنا لمصفوفة النتائج
                'في أول حلقة سيكون مقداره 1 ويمثل أول عمود [J] المتغير المسمى
                'في أول حلقة سيكون مقداره 1 ويمثل أول صف [I] المتغير المسمى
                'أول صف هنا لمصفوفة البيانات الخام
                Temp(P, J) = Arr(I, J)
                
            'الانتقال للحلقة التالية للأعمدة
            Next J
        
        'نهاية جملة الشرط وهو تطابق نص البحث مع العمود رقم 14 في المصفوفة
        End If
    
    'الانتقال للحلقة التالية في صفوف مصفوفة البيانات الخام
    Next I
    
    'إذا كانت قيمة المتغير أكبر من صفر فهذا يعني أنه تم إيجاد نتائج للبحث
    'حيث أن زيادة المتغير كما أوضحنا مقرونة بتحقق الشرط وطالما تحقق الشرط
    'فهذا يعني أن مصفوفة النتائج سيكون بها بيانات ومن ثم يتحقق الجزء الثاني
    
    '[A8] وضع نتائج مصفوفة النتائج في أول خلية في ورقة النتائج في الخلية
    '[P] ويتم تمديد النطاق بمقدار عدد الصفوف طبقاً لقيمة المتغير المسمى
    '[Temp] وبمقدار عدد الأعمدة طبقاً لأكبر عدد لأعمدة المصفوفة المسماة
    If P > 0 Then wsResult.Range("A8").Resize(P, UBound(Temp, 2)).Value = Temp
End Sub

ربنا يكتبها في كفه حسنات المحترم ياسر

[ناصر سعيد]

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

[ناصر سعيد]

في ١٥‏/١١‏/٢٠١٦ at 09:42, ياسر العربى said:

هل تقصد هكذا!

SERCH_ARRY_YASSER_ELARABY - Copy.rar

اريد من احد الافاضل تحويل الملف الى 2003 كرما منكم

[ناصر سعيد]

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("L4:U" & SERCH.Cells(Rows.Count, 12).End(xlUp).Row + 1).ClearContents    'مسح نطاق البحث القديم
    targt = SERCH.Range("e1").Value    'خلية البحث
    targtN = Application.WorksheetFunction.Match(SERCH.Range("D1"), DATA.Range("A1:J1"), 0)    'دالة لايجاد رقم عمود البحث
    myArray = DATA.Range("A2:J" & lr + 1)    'نطاق قاعدةالبيانات الذي سيتم البحث فيه
    '____________________________________________
   ReDim y(1 To UBound(myArray, 1), 1 To UBound(myArray, 2))
    For X = LBound(myArray) To UBound(myArray)
        If targt = "" Then Exit Sub
        If myArray(X, targtN) Like targt & "*" Then
            rw = rw + 1
            For yy = 1 To 10
                y(rw, yy) = myArray(X, yy)
            Next yy
        End If
    Next X
    '____________________________________________________________________________________
    If rw > 0 Then SERCH.Cells(Rows.Count, 12).End(xlUp)(2, 1).Resize(rw, 10).Value = y()
    'التعديل بهذا السطر تقوم بتغيير رقم العمودالمراد
    '____________________________________________________________________________________
End Sub

وهذا يوضع في موديول

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$E$1" Then
        Call Yasser_Serch
    End If
End Sub

هذا الكود يوضع في حدث الورقه

خاص بالبحث

وهذا هو المرفق

في ١٥‏/١١‏/٢٠١٦ at 09:42, ياسر العربى said:

SERCH_ARRY_YASSER_ELARABY - Copy.rar

 

        Range("L4:U4").AutoFill _
    Destination:=Range("L4:U4" & _
    Range("A1").Value + 6), Type:=xlFillDefault

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("L4:U" & SERCH.Cells(Rows.Count, 12) _
    .End(xlUp).Row + 1).ClearContents    'مسح نطاق البحث القديم
    
    
        Range("L4:U4").AutoFill _
    Destination:=Range("L4:U4" & _
    Range("A1").Value + 6), Type:=xlFillDefault

    targt = SERCH.Range("e1").Value    'خلية البحث
    targtN = Application.WorksheetFunction.Match(SERCH.Range("D1"), DATA.Range("A1:J1"), 0)    'دالة لايجاد رقم عمود البحث
    myArray = DATA.Range("A2:J" & lr + 1)    'نطاق قاعدةالبيانات الذي سيتم البحث فيه
    '____________________________________________
   ReDim y(1 To UBound(myArray, 1), 1 To UBound(myArray, 2))
    For X = LBound(myArray) To UBound(myArray)
        If targt = "" Then Exit Sub
        If myArray(X, targtN) Like targt & "*" Then
            rw = rw + 1
            For yy = 1 To 10
                y(rw, yy) = myArray(X, yy)
            Next yy
        End If
    Next X
    '____________________________________________________________________________________
    If rw > 0 Then SERCH.Cells(Rows.Count, 12).End(xlUp)(2, 1).Resize(rw, 10).Value = y()
    'التعديل بهذا السطر تقوم بتغيير رقم العمودالمراد
    '____________________________________________________________________________________
End Sub

به اضافه مفيده وهي نسخ الصف الاول  من الجدول بالعدد الذي تبغاه

 

 

الله يحفظك ياستاذ ياسر العربي

[اوفيس 2003]

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

حيث اضفت في الملف الواحد حوالي 10 سنوات  كل صفحة سنة واحدة  ( 2011 حتى 2020 ) وطبعاً تشمل الالالاف الصفوف ولكني ارفقت مثال مبسط  واريد التالي ::
 

01- اريد ان يكون هناك مربعين بالنسبة لخانة الإسم  إما بحث ببداية الإسم  أو بحث في اي مكان سواء بدايته او متوسط او نهايته  حيث المتواجد البحث ببداية الإسم فقط

02- ان يكون هناك بحث بالسنوات  كأن مثلا ابحث عن رقم الفاتورة او تاريخ او اسم  في سنة معينة  او احدد كافة السنوات

SERCH_ARRY_YASSER_ELARABY2221.zip

تم تعديل ديسمبر 17, 2016 بواسطه اوفيس 2003

[اوفيس 2003]

في انتظار الحل من الإخوة الكرام

 

[tay]

أنت رائع استاذ ياسر العربي ممكن تعديل على ملفك الاول 

لوكان هناك عدة شيتات ، هل ممكن ارفاق خلية بها اختيار الشيت المراد البحث فيه