استخراج الخلايا التي لها لون معين

[ابويوسف2020]

مرحبا بكم 

لدي ملف اكسل فيه مجموعة  من  الشيتات  sheet1 ,2,3,4 واريد ان استخرج منه  تقرير يتم تكوينه في sheet جديد  ويتكون من اسم المدرسة  والمادة التي لديها  رقم في خلية لونها ابيض او احمر والعدد الموجود في الخلية البيضاء والحمراء 

اسم المدرسة             المادة                عدد الطلاب

 

وارفق لكم :

1- ملف الاكسل  (ثاني م ف 2 )

2- شرح المخرج النهائي  (شكل التقرير)

 

وانتم لها 

ثاني م ف 2.rar

شكل التقرير.rar

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

أخي الكريم أبو يوسف

عدد أوراق العمل كبير جداً لذا أفضل إرفاق ملف به 5 أوراق فقط للتجربة عليهم بشكل مبدئي

هل تريد المخرجات تكون كلها في ورقة عمل واحدة لكل أوراق العمل الأخرى ؟؟

رجاءً ارفق شكل النتائج المتوقعة في الملف المرفق (5 أوراق عمل فقط ) لا ترفق المخرجات على شكل صورة بل أنشيء ورقة عمل جديدة وضع شكل النتائج المتوقعة ليسهل العمل على إخوانك بالمنتدى

 

Report.rar

[ابويوسف2020]

شكرا للرد اخي المشرف  الغالي  ياسر خليل 

     طبعا الملف يتم تصديره بأوراقه ولاتقل عن 25 ورقة ، عموما بشكل مبدئي لايمنع ان ارفق هذا الملف الذي ارفقته اخي ياسر

    مايتعلق بالمخرجات نعم نريد ان تكون في ورقة عمل واحدة ضمن الملف

              تم ارفاقها ضمن الملف المرفق في ورقة عمل اسمها ورقة 1 

 

 

         

Report.rar

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

أخي الكريم أبو يوسف

جرب الكود التالي عله يفي بالغرض

Sub YasserReport()
    Dim Ws As Worksheet, Wf As Worksheet, Cel As Range
    Dim TN As Long, S As String, N As String, R As Long, C As Long
    
    Set Wf = Sheets("Final")
    
    Application.ScreenUpdating = False
        For Each Ws In Worksheets
            N = Ws.Name
            If N Like "Sheet*" Then
                For Each Cel In Ws.UsedRange.Offset(20, 1).Resize(, 41)
                    If Not Cel.Row Mod 2 = 0 And Cel.Value <> 0 Then
                        S = Ws.Cells(Cel.Row, 45)
                        TN = Cel.Value
                        N = Ws.Cells(19, Cel.Column)
                        If S <> "" Then
                            If N = "" Then N = Ws.Cells(19, Cel.Column - 1)
                            R = 2
                            Do Until Wf.Range("A" & R) = S Or _
                                Wf.Range("A" & R) = "" And Wf.Range("B" & R) = ""
                                R = R + 1
                            Loop
                            C = 2
                            Do Until Wf.Cells(R, C) = N Or Wf.Cells(R, C) = ""
                                C = C + 2
                            Loop
                            Wf.Cells(R, 1) = S
                            Wf.Cells(R, C) = N
                            Wf.Cells(R, C + 1) = TN
                        End If
                    End If
                Next Cel
            End If
        Next Ws
    Application.ScreenUpdating = True
End Sub

إليك الملف المرفق ..

لا تنسانا بدعوة بظهر الغيب

تقبل تحياتي

 

Grab Data From Sheets Colored In Red Or White YasserKhalil.rar

[ابويوسف2020]

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

واسأل الله لك التوفيق والنجاح والسعادة في النيا والاخرة وان يرزقك الله من واسع فضله

     ملاحظة : عند نقل الكود الى ملف اخر تظهر سالة خطأ

اذا فيه امكانية تنفيذه على هذا الملف او اي ملف مشابه اكون لك من الشاكرين

 

اول م ف 1.rar

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

أخي الكريم أبو يوسف

إليك كود آخر أسرع في التعامل مع الملف حيث أنه يعتمد على المصفوفات

Sub YasserReport()
    Application.ScreenUpdating = 0
    Dim Arr, Xs$, Brr, Dc, Sn%, D As Object, DD As Object, TT(), SSS()
    Dim S As Worksheet
    Dim K, T, C, I As Long, J As Long
    
    Set D = CreateObject("scripting.dictionary")
    Set DD = CreateObject("scripting.dictionary")
    SSS = Array("المادة", "عدد الطلاب")
    Xs = ActiveSheet.Name
    
    For Each S In Sheets
        If S.Name <> Xs Then
            Arr = S.UsedRange: Dc = ""
            For I = 1 To UBound(Arr, 2)
                If Len(Arr(19, I)) = 0 Then Arr(19, I) = Arr(19, I - 1)
                If Len(Arr(21, I)) > 0 Then Dc = Dc & "|" & I
            Next
            Dc = Split(Dc, "|")
            ReDim Brr(1 To UBound(Arr) - 18, 1 To UBound(Dc))
            For I = 19 To UBound(Arr)
                For J = 1 To UBound(Dc)
                    Brr(I - 18, J) = Arr(I, Dc(J))
                Next
            Next
            Sn = UBound(Brr, 2) - 1
            For I = 3 To UBound(Brr) Step 2
                For J = Sn - 2 To 1 Step -1
                    If Val(Brr(I, J)) Then
                        D(Brr(I, Sn) & "|" & Brr(1, J)) = Brr(I, Sn) & "|" & Brr(1, J) & "|" & Brr(I, J)
                    End If
                Next
            Next
        End If
    Next
    
    Debug.Print D.Count
    K = D.keys
    T = D.Items
    For Each C In K
        DD(Split(C, "|")(0)) = ""
    Next
    K = DD.keys
    ReDim TT(UBound(K))
    With Sheets(Xs)
        [A1] = "اسم المدرسة"
        [A2].Resize(DD.Count, 1) = Application.Transpose(K)
        For I = 0 To UBound(K)
            TT(I) = Filter(T, K(I))
            For J = 0 To UBound(TT(I))
                Cells(I + 2, J * 2 + 2) = Split(TT(I)(J), "|")(1)
                Cells(I + 2, J * 2 + 3) = Split(TT(I)(J), "|")(2)
            Next
        Next
        I = [A1].CurrentRegion.Columns.Count
        For J = 2 To I Step 2
            Range(Cells(1, J), Cells(1, J + 1)) = SSS
        Next
        Application.ScreenUpdating = 1
    End With
End Sub

وإليك الملف المرفق الأخير

 

Grab Data From Sheets Colored In Red Or White YasserKhalil V2.rar

[ابويوسف2020]

سلمت اناملك وحفظك الله من كل مكروه 

                  انت رائع اشكرك على حسن اخلاقك وكريم خصالك 

 

تم تعديل ديسمبر 25, 2015 بواسطه ابويوسف2020

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

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

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

إلى لقاء مع موضوع آخر ..

تقبل تحياتي

[مختار حسين محمود]

الله الله عليك أنت اللى ملكش حل رووووووووووووووووووووووووووووووووو عة يا غالى

بارك الله فيك ونفع بك وجعل فى ميزان حسناتك

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

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

تقبل وافر تقديري واحترامي

[مختار حسين محمود]

بارك الله فيك  أخى و حبيبى فى الله و أستاذى الغالى 

ان كنت بعيدا عنكم فأنت وكل الزملاء فى القلب وعلى بالى دائما

-----------------------------------------------------------------------------

مرة تانية أحييك على هذين الكودين الرائعين 

تقبل تقديرى واحترامى لشخصكم الكريم

[KHMB]

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

الاستاذ ياسر خليل

ماشاء الله تبارك الله

في Friday, December 25, 2015 at 10:33, ابويوسف2020 said:

سلمت اناملك وحفظك الله من كل مكروه 

                  انت رائع اشكرك على حسن اخلاقك وكريم خصالك 

 

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

[ابويوسف2020]

تستحقون الشكر

 

بيانات المعلمون (1).zip

[ابويوسف2020]

بيانات المعلمون.rar