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

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


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





تغير فى كود التقرير لمستر سليم الممتاز

الاساتذة مشرفى المنتدى ارجوا المعذرة انا اكثر من اتعمله بلوك بالمنتدى مع العلم لا اخرج عن الحدود وعمرى ما اقدر ارجوا الم ..



13-07-2020 08:57 مساء
yara ahmed
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 07-07-2020
رقم العضوية : 19921
المشاركات : 24
الجنس : أنثى
يتابعهم : 1
يتابعونه : 1
قوة السمعة : 64
 offline 

الاساتذة مشرفى المنتدى ارجوا المعذرة
انا اكثر من اتعمله بلوك بالمنتدى مع العلم لا اخرج عن الحدود وعمرى ما اقدر
ارجوا المعذرة هل اسئلتى لا يستفيد بها الاعضاء الاجابة يستفيد اكيد 
انا حاسة انى بضايق استاذ ياسر مع العلم انا من معجبينه واتابعه من زمن واستفيد من مواضيعه 
اتمنى عدم غلق الموضوع هذاااااااا
عموما اتقدم بالمعذرة
هل استطيع ان اسأل مستر salim بصراحة حضرتك رائع والله
الكود الرائع الخاص بالتقرير
انا غيرت لون التاب من 10 الى3 وبذلك اصبح يستدعى التاب الاحمر تمام
وعدلت فى ارقام الاستدعاء الصفوف ليصبح الاستدعاء من الصف الخامس
ولكن لم استطيع تغير الاسماء فى هذا الصف قبل الاخير
واخفاء الصفوف الخالية من البيانات حتى اتمكن من طباعة التقرير
انا عملى كله استخراج تقارير واحتاج الى التعلم وارجوا من ادارة المنتدى عدم غلق الموضوع
مع خالص الشكر من قلبى لمستر سليم ومستر ياسر
 
 
 
  yara_by_columns.xlsm   تحميل xlsm مرات التحميل :(4)
الحجم :(2828.593) KB


13-07-2020 09:57 مساء
مشاهدة مشاركة منفردة [1]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif تغير فى كود التقرير لمستر سليم الممتاز
تم التعديل كما تريدين
اختيار اللون يتم من خلال الخلية N1 ولا لزوم للدخول الى الكود لتغيير
اللون

Option Explicit
Sub get_special_columns()
Dim D As Worksheet
Dim Sh As Worksheet
Dim Ar(), Min_date As Date, Max_date As Date
Dim K%, t%, Arr_sh()
Dim My_ro%, m%, ro%, my_sum#, x%
K = 2
Set D = Sheets("DataReport")
D.Rows.Hidden = False
If D.Range("A3").CurrentRegion.Rows.Count > 1 Then
  D.Range("A3").CurrentRegion.Offset(1). _
  Resize(D.Range("A3").CurrentRegion.Rows.Count - 1).Clear
End If
If Not IsDate(D.Range("J2")) Or _
 Not IsDate(D.Range("K2")) Then Exit Sub
 Min_date = Application.Min(D.Range("J2:K2"))
 Max_date = Application.Max(D.Range("J2:K2"))
  Ar = Array("E", "F", "G", "H", "I", "J")
For Each Sh In Sheets
    If Sh.Tab.ColorIndex = D.Range("N1") Then
      ReDim Preserve Arr_sh(m)
       Arr_sh(m) = Sh.Name: m = m + 1
     End If
Next Sh
 If m = 0 Then Exit Sub
For m = LBound(Arr_sh) To UBound(Arr_sh)
 D.Cells(K, 1) = Arr_sh(m)
 D.Cells(K + 1, 1) = "Total"
 D.Cells(K + 1, 1).Resize(, UBound(Ar) + 2).Interior.ColorIndex = 20
 K = K + 2
Next m

My_ro = 3
For m = LBound(Arr_sh) To UBound(Arr_sh)
  Set Sh = Sheets(Arr_sh(m))
  Sh.Range("A5:J20000").Interior.ColorIndex = xlNone
   ro = Sh.Cells(Rows.Count, 1).End(3).Row
   For K = LBound(Ar) To UBound(Ar)
        t = K + 2
        For x = 4 To ro
            If Sh.Cells(x, 1) <= Max_date _
            And Sh.Cells(x, 1) >= Min_date Then
              If Val(Sh.Cells(x, Ar(K))) <> 0 Then
                Sh.Cells(x, Ar(K)).Interior.ColorIndex = 6
                my_sum = my_sum + Sh.Cells(x, Ar(K))
              End If
            End If
        Next x
        D.Cells(My_ro, t) = my_sum
        my_sum = 0
   Next K
   My_ro = My_ro + 2
Next m
D.Cells(My_ro, 1) = "Sum Of All"
Rem D.Cells(My_ro - 1, 2).Resize(, UBound(Ar) + 1) = Ar
    With D.Cells(My_ro - 1, 2).Resize(, 6)
      .Value = D.Cells(1, 2).Resize(, 6).Value
      .Interior.Color = vbBlue
      .Font.Color = vbWhite
    End With
D.Cells(My_ro, 2).Resize(, UBound(Ar) + 1).Formula = _
"=Sum(B3:B" & My_ro - 2 & ")"
D.Cells(My_ro, 1).Resize(, UBound(Ar) + 2).Interior.ColorIndex = 6

If D.Range("A3").CurrentRegion.Rows.Count > 1 Then
   With D.Range("A3").CurrentRegion.Offset(1). _
     Resize(D.Range("A3").CurrentRegion.Rows.Count - 1)
    .Borders.LineStyle = 1: .Font.Size = 14
    .Font.Bold = True: .HorizontalAlignment = xlCenter
    .Value = .Value
   End With
End If
 For m = My_ro - 2 To 3 Step -1
  If D.Cells(m, 1) = "Total" And Application.Sum(D.Cells(m, 2).Resize(, 6)) = 0 Then
  D.Cells(m, 1).EntireRow.Hidden = True
  End If
 Next
End Sub
'++++++++++++++++++++++++++++++
Sub show_all()
Sheets("DataReport").Rows.Hidden = False
End Sub

الملف مرفق
 
 
  yara_Col.xlsm   تحميل xlsm مرات التحميل :(10)
الحجم :(3230.187) KB


13-07-2020 10:26 مساء
مشاهدة مشاركة منفردة [2]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10445
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 535
قوة السمعة : 36552
عدد الإجابات: 254
 offline 
look/images/icons/i1.gif تغير فى كود التقرير لمستر سليم الممتاز
الاستفادة تكون أكثر إذا كانت المناقشة حول نقطة محددة ويوجد محاولات من السائل ..لكن ما ألاحظه أنكي تريدين حل جاهز بدون السعي لمحاولة التعلم ، وهذا ما يحدث مع جل الأعضاء للأسف الشديد

13-07-2020 11:00 مساء
مشاهدة مشاركة منفردة [3]
yara ahmed
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 07-07-2020
رقم العضوية : 19921
المشاركات : 24
الجنس : أنثى
يتابعهم : 1
يتابعونه : 1
قوة السمعة : 64
 offline 
look/images/icons/i1.gif تغير فى كود التقرير لمستر سليم الممتاز
حضرتك ساحر مستر سليم اقسم بالله انا مش مصدقة
انت جميل جداااا بسم الله ماشاء الله 
اشكرك جداااااااا والنبى علمنى ههههههه انت مثلى الاعلى
اشكرك من قلبى مع خالص الامانى الطيبة لحضرتك
انا كل شغلى تقارير انا بشوف حضرتك هيرو ماشاء الله عليك
مستر ياسر انا شديدة الاعجاب بيك كل يوم بشتغل باعمالك فى المنتديات واتعلمت كتير جدااا منك
وعندما ناخذ الكود بنعمل عليه بس طبعا خبراتنا صفر بجانب العمالقة
اشكرك بلاش تعمل لى بلوك ههههههههههه
 

13-07-2020 11:27 مساء
مشاهدة مشاركة منفردة [4]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif تغير فى كود التقرير لمستر سليم الممتاز
ممكن الاستعانة بهذا الملف ايضاً (صفحة Sh_all) حيث تظهر الشيتات الحمراء والشيتات الخضراء في نفس الصفحة 
 
 
 
  Yara_salim-Full.xlsm   تحميل xlsm مرات التحميل :(4)
الحجم :(88.589) KB


14-07-2020 12:18 صباحا
مشاهدة مشاركة منفردة [5]
yara ahmed
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 07-07-2020
رقم العضوية : 19921
المشاركات : 24
الجنس : أنثى
يتابعهم : 1
يتابعونه : 1
قوة السمعة : 64
 offline 
look/images/icons/i1.gif تغير فى كود التقرير لمستر سليم الممتاز
اقسم بالله انا مصدومة حضرتك دكتور اكسيل
روعة جداااااااااااا
بس تقرير red
يحتاج نظرة عطف
لان الصفحات الحمراء تقريرها  التقرير الاخير بالمجموع اما الخضراء هى مضبوطة
اما الصفحات الحمراء هذا الكود يعمل تمام
Option Explicit

Sub get_special_columns()

Dim D As Worksheet

Dim Sh As Worksheet

Dim Ar(), Min_date As Date, Max_date As Date

Dim K%, t%, Arr_sh()

Dim My_ro%, m%, ro%, my_sum#, x%

K = 2

Set D = Sheets("DataReport")

D.Rows.Hidden = False

If D.Range("A3").CurrentRegion.Rows.Count > 1 Then

  D.Range("A3").CurrentRegion.Offset(1). _

  Resize(D.Range("A3").CurrentRegion.Rows.Count - 1).Clear

End If

If Not IsDate(D.Range("J2")) Or _

 Not IsDate(D.Range("K2")) Then Exit Sub

 Min_date = Application.Min(D.Range("J2:K2"))

 Max_date = Application.Max(D.Range("J2:K2"))

  Ar = Array("E", "F", "G", "H", "I", "J")

For Each Sh In Sheets

    If Sh.Tab.ColorIndex = D.Range("N1") Then

      ReDim Preserve Arr_sh(m)

       Arr_sh(m) = Sh.Name: m = m + 1

     End If

Next Sh

 If m = 0 Then Exit Sub

For m = LBound(Arr_sh) To UBound(Arr_sh)

 D.Cells(K, 1) = Arr_sh(m)

 D.Cells(K + 1, 1) = "Total"

 D.Cells(K + 1, 1).Resize(, UBound(Ar) + 2).Interior.ColorIndex = 20

 K = K + 2

Next m



My_ro = 3

For m = LBound(Arr_sh) To UBound(Arr_sh)

  Set Sh = Sheets(Arr_sh(m))

  Sh.Range("A5:J20000").Interior.ColorIndex = xlNone

   ro = Sh.Cells(Rows.Count, 1).End(3).Row

   For K = LBound(Ar) To UBound(Ar)

        t = K + 2

        For x = 4 To ro

            If Sh.Cells(x, 1) <= Max_date _

            And Sh.Cells(x, 1) >= Min_date Then

              If Val(Sh.Cells(x, Ar(K))) <> 0 Then

                Sh.Cells(x, Ar(K)).Interior.ColorIndex = 6

                my_sum = my_sum + Sh.Cells(x, Ar(K))

              End If

            End If

        Next x

        D.Cells(My_ro, t) = my_sum

        my_sum = 0

   Next K

   My_ro = My_ro + 2

Next m

D.Cells(My_ro, 1) = "Sum Of All"

Rem D.Cells(My_ro - 1, 2).Resize(, UBound(Ar) + 1) = Ar

    With D.Cells(My_ro - 1, 2).Resize(, 6)

      .Value = D.Cells(1, 2).Resize(, 6).Value

      .Interior.Color = vbBlue

      .Font.Color = vbWhite

    End With

D.Cells(My_ro, 2).Resize(, UBound(Ar) + 1).Formula = _

"=Sum(B3:B" & My_ro - 2 & ")"

D.Cells(My_ro, 1).Resize(, UBound(Ar) + 2).Interior.ColorIndex = 6



If D.Range("A3").CurrentRegion.Rows.Count > 1 Then

   With D.Range("A3").CurrentRegion.Offset(1). _

     Resize(D.Range("A3").CurrentRegion.Rows.Count - 1)

    .Borders.LineStyle = 1: .Font.Size = 14

    .Font.Bold = True: .HorizontalAlignment = xlCenter

    .Value = .Value

   End With

End If

 For m = My_ro - 2 To 3 Step -1

  If D.Cells(m, 1) = "Total" And Application.Sum(D.Cells(m, 2).Resize(, 6)) = 0 Then

  D.Cells(m, 1).EntireRow.Hidden = True

  End If

 Next

End Sub

'++++++++++++++++++++++++++++++

Sub show_all()

Sheets("DataReport").Rows.Hidden = False

End Sub

نستبدله يا دكتور يا جميل 
مع خالص شكرى 
 

14-07-2020 06:56 صباحا
مشاهدة مشاركة منفردة [6]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif تغير فى كود التقرير لمستر سليم الممتاز
تأكدي من وجود صفجات خضراء (لون الــ   Tab أخضر)
لأن عندي الكود يعمل بشكل جيد على اللونين
 
 
 
  yara_Col_test.xlsm   تحميل xlsm مرات التحميل :(9)
الحجم :(4507.816) KB





الكلمات الدلالية
التقرير ، تغير ، لمستر ، سليم ، الممتاز ،


 










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

الساعة الآن 08:35 صباحا