اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


الردود الموصى بها

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

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

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

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

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

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

تم تعديل بواسطه ابو عبدالرحمن البغدادي
رابط هذا التعليق
شارك

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

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

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

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

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

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

تقبل تحياتي

  • Like 1
رابط هذا التعليق
شارك

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

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

وزارات المحافظة_ بطأ استدعاء البيانات عند اجراء البحث في شيت البحث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

  • Like 3
رابط هذا التعليق
شارك

السلام عليكم

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

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

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

انتهى البطأ

اشكرك

تم تعديل بواسطه ابو عبدالرحمن البغدادي
  • Like 2
رابط هذا التعليق
شارك

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

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

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

تقبل تحياتي

رابط هذا التعليق
شارك

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

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

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

تقبل تحياتي

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

  • Like 1
رابط هذا التعليق
شارك

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

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

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

  • Like 1
رابط هذا التعليق
شارك

  • 2 months later...

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information