logo

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



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




موضوع مغلق


  • تمت الإجابة
15-08-2020 08:28 مساءً
معلومات الكاتب ▼
تاريخ الإنضمام : 11-05-2018
رقم العضوية : 6221
المشاركات : 54
الجنس :
تاريخ الميلاد : 29-1-1984
قوة السمعة : 62
الاعجاب : 0
السلام عليكم ورحمة الله وبركاته
استخدمت داله معرفه بهذا الملف لكن الملف اصبح ثقيل جدااااااااا..نظرا لكثرة البيانات.واجد صعوبه بالغه في التعامل معه ...ما اريده هو:
عد الخلايا التي تحتوي على لون معين( وهو اللون الموجود بالملف )...ويكون بها الرقم اكبر من او يساوي 48...حينها يتم العد.
هل ممكن كود بدلا من الداله المعرفه.
attachعد خلايا بشرطين.rar
 
 
  عد خلايا بشرطين.rar   تحميل rar مرات التحميل :(1)
الحجم :(332.246) KB





look/images/icons/i1.gif عد الخلايا الملونه بشرطين
  15-08-2020 09:21 مساءً   [1]
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس :
تاريخ الميلاد : 1-5-1989
الدعوات : 1
قوة السمعة : 6611
الاعجاب : 2
لا حاجة للألوان في هذه الحالة
CODE

Function Count_nageh(rg As Range, ComP As Range)
Dim cel As Range, s%
For Each cel In rg.Cells
    If IsNumeric(cel) And cel >= ComP Then
        s = s + 1
    End If
Next
Count_nageh = s
End Function
'++++++++++++++++++++++++++
Function Count_Raseb(rg As Range, ComP As Range)
Dim cel As Range, s%
For Each cel In rg.Cells
  If IsNumeric(cel) And cel < ComP Then
      s = s + 1
  End If
Next
Count_Raseb = s
End Function
'+++++++++++++++++++++++++++++++
Function Count_Ga3eb(rg As Range, ComP As Range)
Dim cel As Range, s%
For Each cel In rg.Cells
    If cel = ComP Then
      s = s + 1
    End If
Next
Count_Ga3eb = s
End Function


الملف مرفق
 
 
  M_hammouda.xlsm   تحميل xlsm مرات التحميل :(4)
الحجم :(349.435) KB


أثارت هذه المشاركة إعجاب: ali mohamed ali، محمد محمد حمودة،



look/images/icons/i1.gif عد الخلايا الملونه بشرطين
  15-08-2020 10:32 مساءً   [2]
معلومات الكاتب ▼
تاريخ الإنضمام : 11-05-2018
رقم العضوية : 6221
المشاركات : 54
الجنس :
تاريخ الميلاد : 29-1-1984
قوة السمعة : 62
الاعجاب : 0
جزاك الله خيرا استاذ سليم لكن استخدام اللون مهم جدااااااااا جدااااااااا جدااااااااا... لان في خلايا ناجحه غير مظلله....وخلايا ناجحه مظلله...
اريد( عد الخلايا الناجحه المظلله) فقط.
( عد الخلايا الراسبه المظلله).
(عد الخلايا المظلله الغياب)
؟؟؟؟؟؟؟؟؟؟




look/images/icons/i1.gif عد الخلايا الملونه بشرطين
  15-08-2020 10:41 مساءً   [3]
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس :
تاريخ الميلاد : 1-5-1989
الدعوات : 1
قوة السمعة : 6611
الاعجاب : 2
الماكرو لا ينظر الى لون الخلية
بل اذا كانت اكبر او تساوي عدد معين او أصغر من نفس العدد او اذا كانت تساوي "غ"
بالنسبة للتضليل يمكن استعمال التنسيق الشرطي
على العموم مرفق ملف اخر يحتوي على كود
يأخذ معطياته من الخلايا C5 و C7
كما يحتوي على التنسيق الشرطي المطلو ب
(ازرق اكبر او يساوي الخلية C5 اي ناجح واصفر اذا كان غائباً)
الكود
CODE

Dim D As Worksheet
Dim Im As Worksheet
Dim i, s#
Sub find_nageh()
Set D = sheets("data")
Set Im = sheets("Import")
For i = 1 To 4
  Call Find_sum_nageh(sheets("data").Range("E4:H100"), i, Im.Range("C5"))
  Im.Range("J12").Offset(i - 1) = s
  s = 0
  Call Find_sum_Raseb(sheets("data").Range("E4:H100"), i, Im.Range("C5"))
  Im.Range("K12").Offset(i - 1) = s
  s = 0
  Call Find_sum_Gha3eb(sheets("data").Range("E4:H100"), i, Im.Range("C7"))
  Im.Range("L12").Offset(i - 1) = s
  s = 0
 Next
End Sub
'+++++++++++++++++++++++++++++
Sub Find_sum_nageh(Tot_rg As Range, ByVal n%, Alama#)
 For Each cel In Tot_rg.Columns(n).Cells
    If IsNumeric(cel) And cel >= Alama Then
    s = s + 1
   End If
 Next

End Sub
'+++++++++++++++++++++++++++++
Sub Find_sum_Gha3eb(Tot_rg As Range, ByVal n%, Alama)
 For Each cel In Tot_rg.Columns(n).Cells
    If cel = Alama Then
    s = s + 1
   End If
 Next

End Sub
'++++++++++++++++++++++++++++++
Sub Find_sum_Raseb(Tot_rg As Range, ByVal n%, Alama#)
 For Each cel In Tot_rg.Columns(n).Cells
    If IsNumeric(cel) And cel < Alama Then
    s = s + 1
   End If
 Next

End Sub

الملف المرفق يحتوي على الـــ  UDF والماكرو الجديد

 
 
  M_hammouda_Extra.xlsm   تحميل xlsm مرات التحميل :(3)
الحجم :(356.768) KB


أثارت هذه المشاركة إعجاب: ابو طيبه،



look/images/icons/i1.gif عد الخلايا الملونه بشرطين
  15-08-2020 11:14 مساءً   [4]
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس :
تاريخ الميلاد : 1-5-1989
الدعوات : 1
قوة السمعة : 6611
الاعجاب : 2
ملف اخر كما تريده بالضبط
تظلل يدوياً ما تريد والكود يحسب لك ذلك
كذلك الـــ UDF
 
 
  M_hammouda_super.xlsm   تحميل xlsm مرات التحميل :(5)
الحجم :(356.82) KB


أثارت هذه المشاركة إعجاب: محمد محمد حمودة،



look/images/icons/i1.gif عد الخلايا الملونه بشرطين
  16-08-2020 08:42 صباحاً   [5]
معلومات الكاتب ▼
تاريخ الإنضمام : 11-05-2018
رقم العضوية : 6221
المشاركات : 54
الجنس :
تاريخ الميلاد : 29-1-1984
قوة السمعة : 62
الاعجاب : 0
اشكر حضرتك على الملف الرائع وهذا الاهتمام،،
الكود اسرع وافضل ولا يسبب ثقل للملف،،،
لكن ما ينقصه هو اعطائه أمر بتظليل الخلايا الزرقاء فقط؟؟؟!!!
حولت تعديل هذا السطر بالكود وتم بخير

فهل هناك اضافه أخرى..أو ملاحظه من سيادتكم
CODE
If cel.Interior.ColorIndex =24




look/images/icons/i1.gif عد الخلايا الملونه بشرطين
  16-08-2020 09:44 صباحاً   [6]
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس :
تاريخ الميلاد : 1-5-1989
الدعوات : 1
قوة السمعة : 6611
الاعجاب : 2
من باب الاختصار بالكتابة
هذه الصورة
MLW2n_Hammouda_pic
 
 


أثارت هذه المشاركة إعجاب: محمد محمد حمودة،



look/images/icons/i1.gif عد الخلايا الملونه بشرطين
  16-08-2020 11:00 صباحاً   [7]
معلومات الكاتب ▼
تاريخ الإنضمام : 11-05-2018
رقم العضوية : 6221
المشاركات : 54
الجنس :
تاريخ الميلاد : 29-1-1984
قوة السمعة : 62
الاعجاب : 0
ربنا يكرمك ويحفظك
كنت أريد إضافة (ح) لتنضم إلى الراسبين




look/images/icons/i1.gif عد الخلايا الملونه بشرطين
  16-08-2020 12:55 مساءً   [8]
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس :
تاريخ الميلاد : 1-5-1989
الدعوات : 1
قوة السمعة : 6611
الاعجاب : 2
عندها يجب الزيادة على الكود بهذا الشكل
الكود يحسب اي خلية لونها مختلف عن الأبيض
مما يعطيك فرصة لتغيير الالوان حسب الحاجة
مثلاَ: ما تريد من الناجحين لون اصفر
ما تريد من الراسبين لون أحمر
ما تريد من الغائبين لون أخضر وهكذا.....
لك الخيار باختيار اللون رقم 24 الأزرق (حسب التعديل الذي أقترحته انت)

CODE

Dim D As Worksheet
Dim Im As Worksheet
Dim i, s#

Sub find_nageh()
Set D = sheets("data")
Set Im = sheets("Import")

For i = 1 To 4
  Call Find_sum_nageh(D.Range("E4:H100"), i, Im.Range("C5"))
  Im.Range("J12").Offset(i - 1) = s
  s = 0
  
  Call Find_sum_Raseb(D.Range("E4:H100"), i, Im.Range("C5"))
  Im.Range("K12").Offset(i - 1) = s
  s = 0
  
  Call Find_sum_Gha3eb(D.Range("E4:H100"), i, Im.Range("C7"))
  Im.Range("L12").Offset(i - 1) = s
  s = 0
  
  Call Find_sum_special(D.Range("E4:H100"), i, Im.Range("C6"))
  Im.Range("K12").Offset(i - 1) = Im.Range("K12").Offset(i - 1) + s
  s = 0
 Next
Set D = Nothing: Set Im = Nothing
End Sub
'+++++++++++++++++++++++++++++
Sub Find_sum_nageh(Tot_rg As Range, ByVal n%, Alama#)
 For Each cel In Tot_rg.Columns(n).Cells
    If IsNumeric(cel) And cel >= Alama Then
        If cel.Interior.ColorIndex <> xlNone Then
            s = s + 1
        End If
   End If
 Next

End Sub
'+++++++++++++++++++++++++++++
Sub Find_sum_Gha3eb(Tot_rg As Range, ByVal n%, Alama)
 For Each cel In Tot_rg.Columns(n).Cells
    If cel = Alama Then
       If cel.Interior.ColorIndex <> xlNone Then
       s = s + 1
       End If
    End If
 Next

End Sub
'++++++++++++++++++++++++++++++
Sub Find_sum_Raseb(Tot_rg As Range, ByVal n%, Alama)
 For Each cel In Tot_rg.Columns(n).Cells
    If IsNumeric(cel) And cel < Alama Then
        If cel.Interior.ColorIndex <> xlNone Then
           s = s + 1
           
        End If
   End If
 Next

End Sub

'+++++++++++++++++++++++++++
Sub Find_sum_special(Tot_rg As Range, ByVal n%, Alama)
 For Each cel In Tot_rg.Columns(n).Cells
    If cel = Alama Then
        If cel.Interior.ColorIndex <> xlNone Then
           s = s + 1
        End If
   End If
 Next

End Sub



أثارت هذه المشاركة إعجاب: ابو طيبه، محمد محمد حمودة، hassona229، YasserKhalil،



look/images/icons/i1.gif عد الخلايا الملونه بشرطين
  17-08-2020 04:48 صباحاً   [9]
معلومات الكاتب ▼
تاريخ الإنضمام : 11-05-2018
رقم العضوية : 6221
المشاركات : 54
الجنس :
تاريخ الميلاد : 29-1-1984
قوة السمعة : 62
الاعجاب : 0
اشكر حضرتك

[p]
Thank you so much for your giving</pre>

أثارت هذه المشاركة إعجاب: YasserKhalil،






الكلمات الدلالية
الخلايا ، الملونه ، بشرطين ،









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

الساعة الآن 04:41 AM