بطأ استدعاء البيانات عند اجراء البحث

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

السلام عليكم - حياكم الله اخواني واساتذي في منتدى اوفيسنا

توجد عندي مشكلة وهي :

بطأ عند استدعاء البيانات عند اجراء بحث (شيت البحث) ، فعند ادخل البيانات وعددها (35000) موظف في شيت وزارة1 فقط ، وعند اجراء البحث عن الموظف  انتظر طويلاً حتى تأتي البيانات مما سبب لي التأخير في العمل

ممكن وفقكم الله اجراء تعديل على الكود حتى تأتينا البيانات بشكل اسرع ،

ولقد حذفت البيانات بسبب تظهر لي رسالة لا يمكن تحميل الملف الحد المسموح

وزارات المحافظة_ بطأ استدعاء البيانات عند اجراء البحث في شيت البحث.rar

تم تعديل أكتوبر 23, 2015 بواسطه ابو عبدالرحمن البغدادي

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

أخي الكريم أبو عبد الرحمن البغدادي

بالنسبة للملف المرفق في ورقة البحث يرجى إعادة تنظيم الورقة بحيث يسهل الوصول لحل

إن شاء المولى عندي لك حل ، ولكن يرجى إرفاق الملف مرة أخرى مع ضبط ورقة البحث بالشكل الملائم حيث لاحظت أن البيانات في العمود الأول تبدأ من الصف رقم 2 وتنتهي في الصف 26

بينما في العمود الثالث تبدأ من الصف رقم 3 وتنتهي في الصف رقم 27

كما أن البيان الخاص برقم الوزارة مكرر في العمود الأول

لابد من أن يكون الملف منظم حتى يخرج العمل بشكل جيد وتكون النتائج صخيحة ..

تقبل تحياتي

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

السلام عليكم - حياكم الله 

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

وزارات المحافظة_ بطأ استدعاء البيانات عند اجراء البحث في شيت البحث111.rar

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

أخي الكريم جرب الملف المرفق التالي

** الكود مقسم إلى كود يوضع في موديول عادي

Public Arr, ArrOut

Sub RefreshArray()
    Dim WS As Worksheet, ArrTemp, I As Long, P As Long
    ReDim Arr(1, 0)
    For Each WS In Sheets
        If WS.Name <> "البحث" And WS.Name <> "تصفية البيانات المكررة " And WS.Name <> "بيانات ثانوية" Then
        If WS.Cells(Rows.Count, "G").End(xlUp).Row > 1 Then
            ArrTemp = WS.Range("A1").CurrentRegion.Columns("G").Value
            I = UBound(Arr, 2) + UBound(ArrTemp, 1)
            ReDim Preserve Arr(1, I)
            For I = 2 To UBound(ArrTemp, 1)
                If Len(ArrTemp(I, 1)) Then
                    Arr(0, P) = ArrTemp(I, 1)
                    Arr(1, P) = WS.Name & "/" & I
                    P = P + 1
                End If
            Next I
        End If
        End If
    Next WS
    ReDim Preserve Arr(1, P - 1)
End Sub

Sub GetSearchResult(Param As String)
    Dim LastRow As Long, I As Long, P As Long
    If Not IsArray(Arr) Then RefreshArray
    ReDim ArrOut(1, UBound(Arr, 2))
    With Sheets("البحث")
        LastRow = Application.Max(.Cells(.Rows.Count, "E").End(xlUp).Row, 3)
        .Range("E3:E" & LastRow).ClearContents
        P = 0
        For I = LBound(Arr, 2) To UBound(Arr, 2)
            If InStr(1, Arr(0, I), Param, vbTextCompare) Then
                ArrOut(0, P) = Arr(0, I)
                ArrOut(1, P) = Arr(1, I)
                P = P + 1
            End If
        Next I
        If P > 0 And Param <> "" Then
            ReDim Preserve ArrOut(1, P - 1)
            .Range("E3").Resize(UBound(ArrOut, 2) + 1, 1).Value = Application.Transpose(ArrOut)
        Else
            .Range("B2:B26,D2:D26").ClearContents
        End If
    End With
End Sub

Sub RefreshList(Param As Long)
    Dim Arr, ArrOut1(1 To 25, 1 To 1), ArrOut2(1 To 25, 1 To 1), I As Long
    With Sheets("البحث")
        .Range("B2:B26,D2:D26").ClearContents
        On Error Resume Next
        Arr = Sheets(Split(ArrOut(1, Param - 3), "/")(0)).Rows(Val(Split(ArrOut(1, Param - 3), "/")(1))).Resize(, 56).Value
        If Err.Number <> 0 Then Exit Sub
        On Error GoTo 0
        
        ArrOut1(1, 1) = Arr(1, 9)
        For I = 2 To 25
            ArrOut1(I, 1) = Arr(1, I + 5)
        Next I
        
        For I = 1 To 25
            ArrOut2(I, 1) = Arr(1, I + 31)
        Next I
        
        .Range("B2").Resize(UBound(ArrOut1, 1), UBound(ArrOut1, 2)).Value = ArrOut1
        .Range("D2").Resize(UBound(ArrOut2, 1), UBound(ArrOut2, 2)).Value = ArrOut2
    End With
End Sub

والجزء الثاني يوضع في حدث ورقة العمل المسماة "البحث"

Private Sub TextBox1_Change()
    GetSearchResult TextBox1.Text
End Sub

Private Sub Worksheet_Activate()
    RefreshArray
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Columns("E")) Is Nothing Then
        If Target.Row >= 3 And Target.Count = 1 Then
            If Len(Target.Value) Then RefreshList Target.Row
        End If
    End If
End Sub

أرجو أن يكون المطلوب ويعالج مشكلة البطء لديك إن شاء الله

تقبل تحياتي

Textbox Search All Sheets YasserKhalil.rar

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

السلام عليكم

اقول : جزيت خيرا - جزيت خيرا - جزيت خير

اقول : رزقك الله حظ الدنيا والاخرة 

اقول : تمام تمام تمام 100 %

انتهى البطأ

اشكرك

تم تعديل أكتوبر 23, 2015 بواسطه ابو عبدالرحمن البغدادي

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

وعليكم السلام أخي الكريم أبو عبد الرحمن

الحمد لله أن تم المطلوب على خير والحمد لله الذي بنعمته تتم الصالحات

جزيت خيراً بمثل ما دعوت لي

تقبل تحياتي

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

وعليكم السلام أخي الكريم أبو عبد الرحمن

الحمد لله أن تم المطلوب على خير والحمد لله الذي بنعمته تتم الصالحات

جزيت خيراً بمثل ما دعوت لي

تقبل تحياتي

ادخلت بحدود 90000  موظف وما شاء الله سريع الحمد لله

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

يا سلام 

تسلم ابو البراء على المجهود الرائع المبذول منك لخدمة اعضاء المنتدى جزيت خيرا عنا وعن جميع المستفيدين 

 

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

أخي الغالي ياسر العربي

مشكور على مرورك العطر وكلماتك الرقيقة الطيبة ، وجزيت خيراً بمثل ما دعوت

وإن شاء الله نستفيد جميعاً من خبرتك الواسعة (يا ما في الجراب يا عربي)

[محمد صبحى عبدالنعيم]

سلمت يمينك ا ياسر

 

[مختار البركاني]

بارك الله فيك استاذ ياسر خليل 

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