بحث في اكثر من ورقة عمل

[abadi636]

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

جزاكم الله خير نصحني احد الزملاء بان اقوم بطرح سؤالي في منتداكم

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

المطلوب ان اجعل اكسل يقوم باستخراج صفوف بيانات  الطلاب  التي تحتوي على صحي من المصنف  في ورقه جديده ليسهل طباعتها

مرفق بينات الطلاب علما اني لم اقم الى الان بتحديد الحالات الصحيه

 

EL_StudentsNameReport.xlsx

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

[lionheart]

Suppose the word HEALTHY will be in column Q try the following code

Sub Test()
    Const sOut As String = "Output"
    Dim a(1 To 10000, 1 To 1), ws As Worksheet, sh As Worksheet, m As Long, r As Long, k As Long
    Application.ScreenUpdating = False
        Application.DisplayAlerts = False
            On Error Resume Next: Sheets(sOut).Delete: On Error GoTo 0
        Application.DisplayAlerts = True
        For Each ws In ThisWorkbook.Worksheets
            m = ws.Cells(Rows.Count, "V").End(xlUp).Row
            For r = 21 To m
                If ws.Cells(r, "Q").Value = "HEALTHY" Then
                    k = k + 1
                    a(k, 1) = ws.Cells(r, "R").Value
                End If
            Next r
        Next ws
        If k > 0 Then
            Sheets.Add , Sheets(Sheets.Count)
            ActiveSheet.Name = sOut
            With Sheets(sOut)
                .Range("A1").Value = "Results"
                .Range("A2").Resize(UBound(a, 1), UBound(a, 2)).Value = a
            End With
        Else
            MsgBox "No Data", vbExclamation: Exit Sub
        End If
    Application.ScreenUpdating = True
End Sub

 

[abadi636]

ساقوم بعمله وبإذن الله تظبط معي شكرا لك وجزاك الله خير 

[lionheart]

To implement
With your workbook active press Alt+F11 to bring up the vba window
In the Visual Basic window use the menu to Insert|Module
Copy and Paste the code below into the main right hand pane that opens at step 2
Close the Visual Basic window
Press Alt+F8 to bring up the Macro dialog
Select the macro & click Run
Your workbook will need to be saved as a macro-enabled workbook (*.xlsm)

[abadi636]

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

[lionheart]

Please upload a sample file of the expected output that you need exactly

[abadi636]

Thanks 
I need help in the macro you did. I highlight date I need to be in report in sheet 44 as in example.

Thanks so much for your time and patient.

EL_StudentsNameReport (1).xlsm

[lionheart]

Sub Test()
    Const sOut As String = "Output"
    Dim a(1 To 10000, 1 To 4), ws As Worksheet, sh As Worksheet, m As Long, r As Long, k As Long
    Application.ScreenUpdating = False
        Application.DisplayAlerts = False
            On Error Resume Next: Sheets(sOut).Delete: On Error GoTo 0
        Application.DisplayAlerts = True
        For Each ws In ThisWorkbook.Worksheets
            m = ws.Cells(Rows.Count, "V").End(xlUp).Row
            For r = 21 To m
                If Trim(ws.Cells(r, "Q").Value) = "HEALTHY" Then
                    k = k + 1
                    a(k, 1) = ws.Cells(r, "R").Value
                    a(k, 2) = ws.Cells(r, "P").Value
                    a(k, 3) = ws.Range("C6").Value
                    a(k, 4) = ws.Range("B14").Value
                End If
            Next r
        Next ws
        If k > 0 Then
            Sheets.Add , Sheets(Sheets.Count)
            ActiveSheet.Name = sOut
            With Sheets(sOut)
                .Range("A1").Resize(, 4).Value = Array("Names", "Date", "Grade", "Class")
                .Range("A2").Resize(UBound(a, 1), UBound(a, 2)).Value = a
                .DisplayRightToLeft = True
                .Columns.AutoFit
            End With
        Else
            MsgBox "No Data", vbExclamation: Exit Sub
        End If
    Application.ScreenUpdating = True
End Sub

 

Please learn how to click on the LIKE button 

[abadi636]

THANK YOU SO MUCH