أكاديمية الصقر للتدريب

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


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





تكرار كود بحث

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


موضوع مغلق

الصفحة 1 من 2 < 1 2 > الأخيرة »


subject icon تمت الإجابة تكرار كود بحث
15-10-2021 05:57 مساء
علي بطيخ سالم
عضو محترف
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 19-09-2018
رقم العضوية : 8086
المشاركات : 272
الجنس : ذكر
تاريخ الميلاد : 30-10-1982
الدعوات : 1
يتابعهم : 7
يتابعونه : 3
قوة السمعة : 1084
عدد الإجابات: 12
 offline 

السلام عليكم ورحمة الله وبركاته في الملف المرفق كود بحث يعمل بطريقة اوتوماتيكيه واريد التعديل عليه ليتكرر في أكثر من جدول ... بارك الله فيكم
 
 
  كود بحث.xlsm   تحميل xlsm مرات التحميل :(15)
الحجم :(28.145) KB



أفضل إجابة مقدمة من YasserKhalil وهي:
الصراحة لا أدري هل هناك حاجة فعلاً لكل هذه الجداول .. كاقتراح لما لا تحاول أن يكون هناك جدول واحد فقط وتضع خلية بها قائمة منسدلة ومن خلال القائمة تختار الصف المطلوب ويظهر لك نتائج هذا الصف فقط
عموماً جرب هذا الإصدار لعله يكون أسرع 
Sub Test()
    Dim e, ws As Worksheet, sh As Worksheet, tbl As ListObject, r1 As Range, r2 As Range, m As Long
    UseSpeedyCode True
        Set ws = ThisWorkbook.Worksheets("Data")
        Set sh = ThisWorkbook.Worksheets("Search")
        If sh.ListObjects.Count > 0 Then
            For Each tbl In sh.ListObjects
                With tbl.DataBodyRange
                    If .Rows.Count > 1 Then .Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
                    .Rows(1).ClearContents
                End With
            Next tbl
        End If
        If ws.AutoFilterMode = True Then ws.AutoFilterMode = False
        m = ws.Range("A1").CurrentRegion.Rows.Count
        For Each e In Array("C2", "R2", "AG2", "AV2", "BK2", "BZ2", "CO2", "DD2", "DS2", "EH2", "EW2", "FL2", "GA2", "GP2")
            ws.Range("A1").CurrentRegion.AutoFilter 11, sh.Range(e).Value
            Set r1 = Nothing: Set r2 = Nothing
            On Error Resume Next
                Set r1 = ws.Range("A2:D" & m).SpecialCells(xlCellTypeVisible)
                Set r2 = ws.Range("H2:J" & m).SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
            If Not r1 Is Nothing Then r1.Copy sh.Range(e).Offset(4, -2)
            If Not r2 Is Nothing Then r1.Copy sh.Range(e).Offset(4, 2)
            ws.AutoFilterMode = False
        Next e
    UseSpeedyCode False
End Sub

Public Function UseSpeedyCode(goFast As Boolean)
    With Application
        .DisplayAlerts = Not goFast
        .ScreenUpdating = Not goFast
        .EnableEvents = Not goFast
        If goFast Then .Calculation = xlManual Else .Calculation = xlAutomatic
    End With
End Function
عرض الإجابة




16-10-2021 04:51 صباحا
مشاهدة مشاركة منفردة [1]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10444
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 535
قوة السمعة : 36522
عدد الإجابات: 254
 offline 
look/images/icons/i1.gif تكرار كود بحث
وعليكم السلام أخي العزيز علي
لا أدري ما الحكمة من استخدام البحث في مثل هذا الطلب وإرهاق الملف بأكواد في حدث التغيير في أكواد ورقة العمل!
أمر آخر لا يوجد عمود النوع والديانة في ورقة البيانات لذا في الكود سأترك البيان فارغ في هذين العمودين

الكود التالي يقوم بعملية البحث وتعبئة جميع الجداول في ورقة Search مرة واحدة .. كل ما عليك أن تقوم بإنشاء الجداول المطلوبة ووضع عناوين الجداول أي الصفوف المطلوبة كما في ملفك
Sub Test()
    Dim x, v(6), ws As Worksheet, sh As Worksheet, tbl As ListObject, cel As Range, r As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets("Data")
        Set sh = ThisWorkbook.Worksheets("Search")
        If sh.ListObjects.Count > 0 Then
            For Each tbl In sh.ListObjects
                With tbl.DataBodyRange
                    If .Rows.Count > 1 Then .Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
                    .Rows(1).ClearContents
                End With
            Next tbl
        End If
        For r = 2 To ws.Cells(Rows.Count, 1).End(xlUp).Row
            If ws.Cells(r, 1) <> Empty Then
                x = Application.Match(ws.Cells(r, 9).Value, sh.Rows(2), 0)
                If Not IsError(x) Then
                    Set cel = sh.Cells(5, x)
                    If (cel.ListObject Is Nothing) Then GoTo Skipper Else Set tbl = cel.ListObject
                    v(0) = ws.Cells(r, 1).Value
                    v(1) = ws.Cells(r, 2).Value
                    v(2) = ws.Cells(r, 3).Value
                    v(3) = ws.Cells(r, 4).Value
                    v(4) = Empty
                    v(5) = Empty
                    v(6) = ws.Cells(r, 8).Value
                    AddDataRow tbl.Name, v
                End If
            End If
Skipper:
        Next r
    Application.ScreenUpdating = True
End Sub

Sub AddDataRow(tableName As String, values() As Variant)
    Dim wks As Worksheet, tb As ListObject, c As Range, col As Integer
    Set wks = ThisWorkbook.Worksheets("Search")
    Set tb = wks.ListObjects.Item(tableName)
    If tb.ListRows.Count > 0 Then
        Set c = tb.ListRows(tb.ListRows.Count).Range
        For col = 1 To c.Columns.Count
            If Trim(CStr(c.Cells(1, col).Value)) <> "" Then tb.ListRows.Add: Exit For
        Next col
    Else
        tb.ListRows.Add
    End If
    Set c = tb.ListRows(tb.ListRows.Count).Range
    For col = 1 To c.Columns.Count
        If col <= UBound(values) + 1 Then c.Cells(1, col) = values(col - 1)
    Next col
End Sub

16-10-2021 09:10 مساء
مشاهدة مشاركة منفردة [2]
علي بطيخ سالم
عضو محترف
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 19-09-2018
رقم العضوية : 8086
المشاركات : 272
الجنس : ذكر
تاريخ الميلاد : 30-10-1982
الدعوات : 1
يتابعهم : 7
يتابعونه : 3
قوة السمعة : 1084
عدد الإجابات: 12
 offline 
look/images/icons/i1.gif تكرار كود بحث
121 انا عن نفسي سألت نفسي ليه اللفة الطويلة العريضة دي لاني كنت بنفذها بالدوال لكن فكرت في موضوع الكود وقولت انه ممكن يحل لي الربكة المعقدة دي وبصراحة حضرتك واساتذتنا في المنتدى الرائع زي المصباح بتاع علاء الدين... نفسي اتعلم ربع ذلك لكن من اول ما ادخل في موضوع الأكواد دا باتووووه يلا عموما زادك الله من فضله علماً وشرفاً وعزة استاذنا الفاضل ونسأل الله ان يبارك في عمرك وان يجعل ما تقدمه في ميزان حسناتك اللهم آمين يارب العالمين 

17-10-2021 04:33 صباحا
مشاهدة مشاركة منفردة [3]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10444
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 535
قوة السمعة : 36522
عدد الإجابات: 254
 offline 
look/images/icons/i1.gif تكرار كود بحث
بارك الله فيك أخي العزيز علي ومشكور على دعواتك الطيبة
موضوع الأكواد بالممارسة والتطبيق وعدم اليأس والمحاولات مراراً وتكراراً ، وأنا طالب علم لا أكثر  وما زلت أتعلم كل يوم الجديد في هذا المجال فالتعلم عملية مستمرة لا تنتهي 

والحمد لله الذي بنعمته تتم الصالحات.

17-10-2021 05:30 مساء
مشاهدة مشاركة منفردة [4]
علي بطيخ سالم
عضو محترف
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 19-09-2018
رقم العضوية : 8086
المشاركات : 272
الجنس : ذكر
تاريخ الميلاد : 30-10-1982
الدعوات : 1
يتابعهم : 7
يتابعونه : 3
قوة السمعة : 1084
عدد الإجابات: 12
 offline 
look/images/icons/i1.gif تكرار كود بحث
بعد التطبيق وإضافة قاعدة بيانات على الملف وبعض الدوال الكود يستغرق وقت كبير للتنفيذ بالإضافة لاستهلاك قدر كبير من موارد الجهاز 
 
 
  كود بحث (3).xlsm   تحميل xlsm مرات التحميل :(7)
الحجم :(372.866) KB


17-10-2021 06:39 مساء
مشاهدة مشاركة منفردة [5]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10444
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 535
قوة السمعة : 36522
عدد الإجابات: 254
 offline 
look/images/icons/i1.gif تكرار كود بحث
الصراحة لا أدري هل هناك حاجة فعلاً لكل هذه الجداول .. كاقتراح لما لا تحاول أن يكون هناك جدول واحد فقط وتضع خلية بها قائمة منسدلة ومن خلال القائمة تختار الصف المطلوب ويظهر لك نتائج هذا الصف فقط
عموماً جرب هذا الإصدار لعله يكون أسرع 
Sub Test()
    Dim e, ws As Worksheet, sh As Worksheet, tbl As ListObject, r1 As Range, r2 As Range, m As Long
    UseSpeedyCode True
        Set ws = ThisWorkbook.Worksheets("Data")
        Set sh = ThisWorkbook.Worksheets("Search")
        If sh.ListObjects.Count > 0 Then
            For Each tbl In sh.ListObjects
                With tbl.DataBodyRange
                    If .Rows.Count > 1 Then .Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
                    .Rows(1).ClearContents
                End With
            Next tbl
        End If
        If ws.AutoFilterMode = True Then ws.AutoFilterMode = False
        m = ws.Range("A1").CurrentRegion.Rows.Count
        For Each e In Array("C2", "R2", "AG2", "AV2", "BK2", "BZ2", "CO2", "DD2", "DS2", "EH2", "EW2", "FL2", "GA2", "GP2")
            ws.Range("A1").CurrentRegion.AutoFilter 11, sh.Range(e).Value
            Set r1 = Nothing: Set r2 = Nothing
            On Error Resume Next
                Set r1 = ws.Range("A2:D" & m).SpecialCells(xlCellTypeVisible)
                Set r2 = ws.Range("H2:J" & m).SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
            If Not r1 Is Nothing Then r1.Copy sh.Range(e).Offset(4, -2)
            If Not r2 Is Nothing Then r1.Copy sh.Range(e).Offset(4, 2)
            ws.AutoFilterMode = False
        Next e
    UseSpeedyCode False
End Sub

Public Function UseSpeedyCode(goFast As Boolean)
    With Application
        .DisplayAlerts = Not goFast
        .ScreenUpdating = Not goFast
        .EnableEvents = Not goFast
        If goFast Then .Calculation = xlManual Else .Calculation = xlAutomatic
    End With
End Function

17-10-2021 07:59 مساء
مشاهدة مشاركة منفردة [6]
علي بطيخ سالم
عضو محترف
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 19-09-2018
رقم العضوية : 8086
المشاركات : 272
الجنس : ذكر
تاريخ الميلاد : 30-10-1982
الدعوات : 1
يتابعهم : 7
يتابعونه : 3
قوة السمعة : 1084
عدد الإجابات: 12
 offline 
look/images/icons/i1.gif تكرار كود بحث
استاذنا الفاضل أنا بالفعل عاجز عن الشكر، ورداً على تساؤل حضرتك أنا بحاول أعمل قاعدة بيانات تضم جميع البيانات والمعلومات حول الطلبة، وأحتاج لهذه الجداول حتى أجعل جميع المعلومات الخاصة بالقيد متوافرة في آن واحد (القيد العام لطلاب المدرسة بالكامل من أعداد بنون وبنات ومسلم ومسيحي ومستجد ومنقول وباق ومنازل) الموضوع فيه شوية تفاصيل أنا أحتاج إليها متوافرة بضغطة زر واحدة ولذلك كان الكود الأول في حدث الشيت أنا قمت من فترة بالاستعانة بالدوال وكانت نتائجها مرضية في الحقيقة لكن فكرت في تطوير الملف وعندما رجعت لهذه الصفحة وجدت نفسي دوخت من التعديل على الدوال في كل عمود ففكرت في موضوع الكود وفي حقيقة الأمر أنا أعلم أن صدركم الرحب يسع لهذه المواضيع... أنا فكرت أيضاً في رفع الملف الذي أعمل عليه كاملاً لكن به بيانات خاصة بالطلاب وأولياء أمورهم ... أطلت الحديث عليكم لكن يبقى في الأخير الشكر والتقدير والاحترام لحضرتكم استاذنا الأستاذ ياسر جزاكم الله خيراً وبارك الله لك وأسكنك الله ووالديك والمسلمين الفردوس الأعلى اللهم آمين.


الصفحة 1 من 2 < 1 2 > الأخيرة »


الكلمات الدلالية
تكرار ،


 










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

الساعة الآن 07:25 صباحا