ضم (Macro1) و (Macro2) معا وتوحيد البحث في شيت واحد

[algammal]

السادة الأفاضل الكرام خبراء أوفيسنا (Excel)

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

طبتم وطابت أوقاتكم بكل خير

وبعد

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

·       قمت بإنشاء: (Macro1) و (Macro2) و (Module3) و (Module4)؛ كما هو موضح بملف العمل المرفق حيث:   

·       شيت (search DATA) مرتبط بـ (Macro1) وهذا مبين في (Module3).

·       وشيت (search معاشات) مرتبط بـ (Macro2) وهذا مبين في (Module4).

·   المطلوب

·       أن يصبح شيت (SEARCH) هو شيت البحث الرئيس لما يحتويه شيت (search DATA) وشيت (search معاشات) ثم يتم حذف كلا الشيتين لعدم الحاجة إليهما.

·أو

·       ضم شيت (search معاشات) إلى شيت (search DATA) وحذف شيت (search معاشات) لعدم الحاجة إليه بعد أن يصبح شيت (search DATA) هو شيت البحث الرئيس وتغيير اسمه ليكون شيت (SEARCH).  

ملاحظة

·       أمكنني البحث بأي من محتويات الخلايا (M4:A4) ماعدا الخليتان: (G5) محافظة الميلاد (المظللة باللون الأصفر) و (K5) يوم الخروج للمعاش (المظللة باللون الأصفر)؛ ولا أعلم سببا لذلك؛ في كلا من شيتي: (search DATA) و (search معاشات).  

شاكر لكم حسن تعاونكم مسبقا ولكم خالص الشكر والتقدير والاحترام.

ضم ماكرو1 وماكرو2 معا وتوحيد البحث في شيت واحد.xlsb

[Foksh]

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

أشكرك على هذه الثقة أخي الفاضل @algammal ، وأتمنى ان نكون عند حسن الظن بها .. وطبعاً البركة في خبرائكم ومعلمينا الأفاضل هنا ، فأنا ما زلت اكتسب المعلومة في هذا الصرح الكبير .

 

بحد علمي وفهمي البسيط في اكسل ، قمت بدمج بيانات الشيتين (search DATA) و (search معاشات) في الشيت Search .

ثم جعلت الفلترة بشكلين ، إما عن موظف محدد باسمه مثلاً أو رقمه القومي كبيانات فريدة ( افتراضاً مني ) ، أو الفلترة الشاملة كما في الصورة :-

 

واستخدمت الماكرو الأول للـ بحث عن سجل محدد :-

Sub SearchOne()
    Dim ws As Worksheet
    Dim findRange As Range
    Dim searchCol As Long
    Dim searchValue As String
    Dim foundCell As Range
    Dim lastRow As Long
    
    Set ws = ThisWorkbook.Sheets("SEARCH")
    
    For searchCol = 1 To 13
        If Not IsEmpty(ws.Cells(5, searchCol)) Then
            searchValue = ws.Cells(5, searchCol).Value
            
            lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            Set findRange = ws.Range(ws.Cells(10, searchCol), ws.Cells(lastRow, searchCol))
            
            Set foundCell = findRange.Find(What:=searchValue, LookIn:=xlValues, LookAt:=xlWhole)
            
            If Not foundCell Is Nothing Then
                ws.Range(foundCell.EntireRow.Address).Copy
                ws.Range("A5").PasteSpecial xlPasteValues
                Exit For
            End If
        End If
    Next searchCol
    
    Application.CutCopyMode = False
End Sub

 

وفي زر الفلترة الشاملة :-

Sub SearchAlls()
    Dim ws As Worksheet
    Dim searchCol As Long
    Dim searchValue As String
    Dim lastRow As Long
    
    Set ws = ThisWorkbook.Sheets("SEARCH")
    
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    
    For searchCol = 1 To 13
        If Not IsEmpty(ws.Cells(5, searchCol)) Then
            searchValue = ws.Cells(5, searchCol).Value
            
            lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            ws.Range("A9:M" & lastRow).AutoFilter
            ws.Range("A9:M" & lastRow).AutoFilter Field:=searchCol, Criteria1:=searchValue
            
            Exit For
        End If
    Next searchCol
End Sub

 

وفي زر مسح الفلترة :-

Sub ClearSearch()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("SEARCH")
    
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    
    ws.Range("A5:M5").ClearContents
End Sub

 

هذا بحد فهمي للمطلوب ، وأرجو ان لا أكود قد صوبت إجابتي بشكل بعيد كلياً عن المطلوب ,🙃,

 

الملف بعد التعديل :-

توحيد البحث في شيت واحد.xlsb

 

جرب النتائج ، وأخبرني بها .

[algammal]

أخي الفاضل الأستاذ / @Foksh

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

13 ساعات مضت, Foksh said:

هذا بحد فهمي للمطلوب ، وأرجو ان لا أكود قد صوبت إجابتي بشكل بعيد كلياً عن المطلوب ,🙃,

 

لا عليك يا أخي؛ فلقد أصبت الهدف؛ يتبقى ملحوظة مهمة أرجو أن يتم أخذها بعين الاعتبار ألا وهي:

تحديث بيانات شيت (SEARCH) دوما بطريقة ديناميكية كلما تم تعديل في شيت (DATA) وشيت (معاشات).

وتقبل خالص شكري وتقديري؛ وجزاكم الله خير الجزاء؛ وبارك الله فيكم؛ ودمتم عونا لنا ولكل من أراد العون.

[Foksh]

منذ ساعه, algammal said:

أخي الفاضل الأستاذ / @Foksh

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

لا عليك يا أخي؛ فلقد أصبت الهدف؛ يتبقى ملحوظة مهمة أرجو أن يتم أخذها بعين الاعتبار ألا وهي:

تحديث بيانات شيت (SEARCH) دوما بطريقة ديناميكية كلما تم تعديل في شيت (DATA) وشيت (معاشات).

وتقبل خالص شكري وتقديري؛ وجزاكم الله خير الجزاء؛ وبارك الله فيكم؛ ودمتم عونا لنا ولكل من أراد العون.

حسناً ، سأرى ما يمكنني فعله عند عودتي للمنزل ان شاء الله مساءً ..

وقد نبحث عن حل آخر لحل مشكلة تتالي التحديث على البيانات

[Foksh]

19 ساعات مضت, algammal said:

تحديث بيانات شيت (SEARCH) دوما بطريقة ديناميكية كلما تم تعديل في شيت (DATA) وشيت (معاشات).

 

تم انشاء استدعاء لدالة للتحديث التلقائي عند فتح الشيت Search في ThisWorkbook كالآتي :-

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    If Sh.Name = "SEARCH" Then
        Call UpdateSearchSheet
        With ThisWorkbook.Sheets("SEARCH")
            .Range("B5").Select
        End With
    End If
End Sub

 

وطبعاً دالة التحديث التلقائي :-

Sub UpdateSearchSheet()
    Dim wsSearch As Worksheet
    Dim wsData As Worksheet
    Dim wsPensions As Worksheet
    Dim lastRowData As Long
    Dim lastRowPensions As Long
    Dim lastRowSearch As Long
    
    Set wsSearch = ThisWorkbook.Sheets("SEARCH")
    Set wsData = ThisWorkbook.Sheets("DATA")
    Set wsPensions = ThisWorkbook.Sheets("معاشات")
    
    wsSearch.Range("A10:M1000").ClearContents
    
    lastRowData = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
    If lastRowData > 9 Then
        wsData.Range("A10:M" & lastRowData).Copy
        wsSearch.Range("A10").PasteSpecial xlPasteValues
    End If
    
    lastRowSearch = wsSearch.Cells(wsSearch.Rows.Count, "A").End(xlUp).Row
    If lastRowSearch < 10 Then lastRowSearch = 9
    lastRowPensions = wsPensions.Cells(wsPensions.Rows.Count, "A").End(xlUp).Row
    If lastRowPensions > 9 Then
        wsPensions.Range("A10:M" & lastRowPensions).Copy
        wsSearch.Range("A" & lastRowSearch + 1).PasteSpecial xlPasteValues
    End If
    
    Application.CutCopyMode = False
End Sub

 

وبشكل اختياري ، زر تحديث يدوي :-

Sub RefreshSearchData()
    Call UpdateSearchSheet
    With ThisWorkbook.Sheets("SEARCH")
        .Range("B5").Select
    End With
    MsgBox "تم تحديث البيانات بنجاح", vbInformation
End Sub

 

توحيد البحث في شيت واحد.xlsb

تم تعديل منذ 16 ساعات بواسطه Foksh
تصحيح خطأ مطبعي ،،

[algammal]

أخي الكريم الأستاذ / @Foksh

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

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

1)   التسلسل في شيت (SEARCH) نسي (5) الخمسة صفوف الأولى من شيت (DATA) وبدأ الترقيم من رقم (6)؛ والمفترض أن الخمسة صفوف الأولى من شيت (DATA) من (B5) وحتى (B9) تأخذ مكانها في شيت (SEARCH).

2)   لو أمعنا النظر في شيت (SEARCH) جيدا ولاحظنا أول اسم في الشيت لوجدناه في خلية (B10) بإسم (محمد 128)

3)   ولو لاحظنا آخر الشيت ذاته لوجدنا أن أسماء شيت (معاشات) مكررة فيه بداية من خلية (B7855) بإسم (محمد 98) وحتى خلية (B7871) باسم (محمد 95) هذا ولا نريد تكرار هذه الأسماء في هذا الموضع أو غيره نهائيا علما بأن التكرار أيضا نسي (5) الخمسة صفوف الأولى من شيت (معاشات) ويبدأ الترقيم من رقم (6).

4)   لو أمعنا النظر في شيت (DATA) في الخلية (B10) لوجدناها باسم (محمد 128)؛ ولو قمنا بتغيير الرقم القومي الخاص بهذا الاسم ليصبح (26505071500030) بدلا من (26508071500030) ليصبح تاريخ إحالته على المعاش هو (06/05/2025) ثم قمنا بالضغط على زر (ترحيل المحالين على المعاش) الموجود في شيت (DATA) لتم ترحيل الاسم إلى شيت (معاشات) وأصبح في الخلية (B27) وهو بهذا الشكل يصبح في التسلسل التصاعدي الطبيعي له طبقا لتاريخ الإحالة للمعاش وهذا جهدا خالصا للأستاذ / @عبدالله بشير عبدالله الذي لم يدخر جهدا ولم يمل من كثرة تساؤلاتنا حتى وصل بنا لعمل يستحق عليه الشكر والثناء فجزاه الله عنا خير الجزاء؛ وأيضا لتم حذف الاسم من شيت (DATA) ويتم تغيير التسلسل الخاص بالترقيم تلقائيا ولا يتأثر سواء بالحذف أو الإضافة.  

5)   لو عدنا إلى شيت (SEARCH) لوجدنا اسم (محمد 128) قد تم حذفه من خلية (B10) وحل الاسم التالي له في الشيت نفسه مكانه ليصبح (محمد 129) والمفترض أن اسم (محمد 128) يتم إضافته في شيت (SEARCH) ليصبح في الخلية (B7855) ويتم حذف الأسماء المكررة المشار إليها سابقا في الملحوظة رقم (3) ولو ضغطنا على زر (Ref) الخاص بتحديث البيانات في الشيت نفسه لخرجت لنا رسالة تخبرنا بأنه (تم تحديث البيانات بنجاح) علما بأنه لم يتغير من الأمر شيء فالمكرر كما هو والاسم الذي تم حذفه من الشيت لم يأخذ مكانه الآخر والمفترض أن يكون فيه في نفس الشيت.

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

ملحوظة: أخي الكريم الأستاذ / @Foksh لا أريد أن أثقل عليكم إن تم الأخذ بالملاحظات وتم التوصل لحل لها فخير ونعمة وإن لم يكن فلا بأس؛ وجزاكم الله خير الجزاء على ما قمتم به وقدمتموه لنا.

[عبدالله بشير عبدالله]

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

الاستاذ الفاضل  algammal

جزاك الله كل خيرا  على  ثتاؤك ودعائك لي 

الاستاذ الفاضل  Foksh

 

تحية لك ولاخواننا في منتدى الاكسس 

بعد اذنكما

ساطرح فكرة اخرى لطلب حبيبنا algammal

حسب فهمى لطلبكم انكم تريدون البحث باسم الموظف او الرقم الوطني  او من  وظيفتهم طبيب كمثال 

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

الفكرة كود يقوم بالبحث في شيت معاشات وشيت data  باستخذام النطاق a5:m5 في شيت search  ونتيجة البحث ينم وضعها في نفس الشيت بداية من A10

تم عمل قائمة بالاسماء بدل كنابنها ويتم تحديثها يدويا  بواسطة زر وتتحدث تلقائيا عتد الانتهاء من البحث

الملف المرفق يوضح الفكرة

 لكما ولكل اعضاء المنتدى وافر التقدير والاخترام

فكرة اخرى للبحث.xlsb

تم تعديل منذ 6 ساعات بواسطه عبدالله بشير عبدالله

[Foksh]

بناءً على المطلوب الأخير لك ، ومشاركة مع أستاذنا @عبدالله بشير عبدالله ،،

قمت بحذف الدوال السابقة للبحث ، واستبدلتها بفكرة واحدة بحيث ( لا حاجة فعلاً لتكرار البيانات في الأوراق جميعها ، وقد تم حذف البيانات في الورقة Search ، وستكون دالة البحث ودالة مسح وتنظيف نتائج البحث كالتالي :-

 

Sub SearchAll()
    Dim wsSearch As Worksheet
    Dim wsData As Worksheet
    Dim wsPensions As Worksheet
    Dim searchCol As Long
    Dim searchValue As String
    Dim lastRowData As Long
    Dim lastRowPensions As Long
    Dim resultRow As Long
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Set wsSearch = ThisWorkbook.Sheets("SEARCH")
    Set wsData = ThisWorkbook.Sheets("DATA")
    Set wsPensions = ThisWorkbook.Sheets("معاشات")
    
    wsSearch.Range("A10:M1000").ClearContents
    resultRow = 10
    
    For searchCol = 1 To 13
        If Not IsEmpty(wsSearch.Cells(5, searchCol)) Then
            searchValue = wsSearch.Cells(5, searchCol).Value
            
            lastRowData = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
            If lastRowData > 4 Then
                With wsData.Range("A5:M" & lastRowData)
                    .AutoFilter
                    .AutoFilter Field:=searchCol, Criteria1:="=" & searchValue, _
                               Operator:=xlAnd
                    On Error Resume Next
                    .Offset(1).SpecialCells(xlCellTypeVisible).Copy
                    wsSearch.Cells(resultRow, 1).PasteSpecial xlPasteValues
                    On Error GoTo 0
                    .AutoFilter
                End With
            End If
            
            resultRow = wsSearch.Cells(wsSearch.Rows.Count, "A").End(xlUp).Row + 1
            If resultRow < 10 Then resultRow = 10
            
            lastRowPensions = wsPensions.Cells(wsPensions.Rows.Count, "A").End(xlUp).Row
            If lastRowPensions > 4 Then
                With wsPensions.Range("A5:M" & lastRowPensions)
                    .AutoFilter
                    .AutoFilter Field:=searchCol, Criteria1:="=" & searchValue, _
                               Operator:=xlAnd
                    On Error Resume Next
                    .Offset(1).SpecialCells(xlCellTypeVisible).Copy
                    wsSearch.Cells(resultRow, 1).PasteSpecial xlPasteValues
                    On Error GoTo 0
                    .AutoFilter
                End With
            End If
            
            Exit For
        End If
    Next searchCol
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.CutCopyMode = False
End Sub

Sub ClearSearch()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("SEARCH")
    
    ws.Range("A10:M1000").ClearContents
    ws.Range("A5:M5").ClearContents
    
    ws.Range("B5").Select
End Sub

 

 

توحيد البحث في شيت واحد_01.xlsb

[محمد هشام.]

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

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

وتقوم الفكرة على الاستغناء الكامل عن ورقة SEARCH بما في ذلك التصفية التقليدية في النطاق A5:M5 وذلك من خلال استخدام نموذج بحث (UserForm) متكامل مرتبط مباشرة بقاعدة البيانات
هذا النموذج يوفر المزايا التالية:

البحث الفوري والتصفية المباشرة من ورقة DATA باستخدام قوائم منسدلة ComboBoxes ديناميكية 

إمكانية ترحيل النتائج إلى ورقة أخرى SEARCH عند الحاجة لذلك 

واجهة مرنة قابلة للتطوير تغني تماما عن الحاجة إلى أوراق وسيطة مما يجعل العمل أكثر تنظيما وسلاسة

عرض عدد النتائج بعد التصفية بشكل تلقائي 

يشرفني أن أشارك هذه الفكرة المتواضعة في سبيل إثراء هذا العمل المميز وآمل أن تشكل إضافة مفيدة ضمن هذا الجهد الرائع

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

مع خالص التقدير والاحترام للجميع

 

توحيد البحث في شيت واحد v1.xlsb

تم تعديل منذ 33 دقائق بواسطه محمد هشام.

[Foksh]

لوجود خطأ في نتائج البحث بعد التجربة ، قمت بالتعديل التالي على دالة البحث الرئيسية على سبيل المثال :-

Sub SearchAll()
    Dim wsSearch As Worksheet
    Dim wsData As Worksheet
    Dim wsPensions As Worksheet
    Dim searchCol As Long
    Dim searchValue As String
    Dim resultRow As Long
    Dim visibleRange As Range
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set wsSearch = ThisWorkbook.Sheets("Search")
    Set wsData = ThisWorkbook.Sheets("Data")
    Set wsPensions = ThisWorkbook.Sheets("معاشات")
    
    wsSearch.Range("A10:M1000").ClearContents
    resultRow = 10
    
    For searchCol = 1 To 13
        If Not IsEmpty(wsSearch.Cells(5, searchCol)) Then
            searchValue = Application.Clean(Trim(wsSearch.Cells(5, searchCol).Text))
            
            With wsData
                .AutoFilterMode = False
                .Range("A4:M" & .Rows.Count).AutoFilter Field:=searchCol, Criteria1:=searchValue
                On Error Resume Next
                Set visibleRange = .AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible)
                If Not visibleRange Is Nothing Then
                    visibleRange.Copy
                    wsSearch.Cells(resultRow, 1).PasteSpecial xlPasteValues
                    resultRow = resultRow + visibleRange.Rows.Count
                End If
                On Error GoTo 0
                .AutoFilterMode = False
            End With
            
            With wsPensions
                .AutoFilterMode = False
                .Range("A4:M" & .Rows.Count).AutoFilter Field:=searchCol, Criteria1:=searchValue
                On Error Resume Next
                Set visibleRange = .AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible)
                If Not visibleRange Is Nothing Then
                    visibleRange.Copy
                    wsSearch.Cells(resultRow, 1).PasteSpecial xlPasteValues
                    resultRow = resultRow + visibleRange.Rows.Count
                End If
                On Error GoTo 0
                .AutoFilterMode = False
            End With
            
            Exit For
        End If
    Next searchCol
    
    Application.Calculation = xlCalculationAutomatic
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

توحيد البحث في شيت واحد_01.xlsb