جمع الخلايا الملونة بلون واحد

[shshorbagy]

الاخوة الاعزاء في المنتدي الكريم

كما تعودنا منكم الرد علينا في استفسارتنا ومشاكلنا

ارجو منكم حل هذه المشكلة لو سمحتم

عندي ملف اكسيل بالعمل ارغب في جمع الخلايا التي اظللها بلون نختلف

بحيث اني اقوم بتلوين بعض الخلايا علي طول الشهر بالوان مختلفه

كل لون له معني عندي في عملي

اي يجمع الالوان الصفراء في خلية واحده

والزرقاء في خلية اخري

وهكذا

اخوكم شريف

[Bluemind]

الاخوة الاعزاء في المنتدي الكريم

كما تعودنا منكم الرد علينا في استفسارتنا ومشاكلنا

ارجو منكم حل هذه المشكلة لو سمحتم

عندي ملف اكسيل بالعمل ارغب في جمع الخلايا التي اظللها بلون نختلف

بحيث اني اقوم بتلوين بعض الخلايا علي طول الشهر بالوان مختلفه

كل لون له معني عندي في عملي

اي يجمع الالوان الصفراء في خلية واحده

والزرقاء في خلية اخري

وهكذا


اخوكم شريف


اخوي شريف بارك الله فيك
اولا تحتاج الى انشاء داله اسمها colorindex
وذلك بنسخ الكود التالي ثم لصقه في مودل جديد
'---------------------------------------------------------------------
' ColorIndex Function
'---------------------------------------------------------------------
' Function: Returns the colorindex of the supplied range
' Synopsis: Initially, gets a colorindex value for black and white
' from the activeworkbook colour palette
' Then works through each cell in the supplied range and
' determines the colorindex, and adds to array
' Finishes by returning acumulated array
' Variations: Determines cell colour (interior) or text colour (font)
' Default is cell colour
' Constraints: Does not count colours set by conditional formatting
'---------------------------------------------------------------------
' Author: Bob Phillips
' Additions for ranges suggested by Harlan Grove
'---------------------------------------------------------------------


'---------------------------------------------------------------------
Function ColorIndex(rng As Range, _
Optional text As Boolean = False) As Variant
'---------------------------------------------------------------------
Dim cell As Range, row As Range
Dim i As Long, j As Long
Dim iWhite As Long, iBlack As Long
Dim aryColours As Variant

If rng.Areas.Count > 1 Then
ColorIndex = CVErr(xlErrValue)
Exit Function
End If

iWhite = WhiteColorindex(rng.Worksheet.Parent)
iBlack = BlackColorindex(rng.Worksheet.Parent)

If rng.Cells.Count = 1 Then
If text Then
aryColours = DecodeColorIndex(rng, True, iBlack)
Else
aryColours = DecodeColorIndex(rng, False, iWhite)
End If

Else
aryColours = rng.Value
i = 0

For Each row In rng.Rows
i = i + 1
j = 0

For Each cell In row.Cells
j = j + 1

If text Then
aryColours(i, j) = _
DecodeColorIndex(cell,True,iBlack)
Else
aryColours(i, j) = _
DecodeColorIndex(cell,False,iWhite)
End If

Next cell

Next row

End If

ColorIndex = aryColours

End Function

'---------------------------------------------------------------------
Private Function WhiteColorindex(oWB As Workbook)
'---------------------------------------------------------------------
Dim iPalette As Long
WhiteColorindex = 0
For iPalette = 1 To 56
If oWB.Colors(iPalette) = &HFFFFFF Then
WhiteColorindex = iPalette
Exit Function
End If
Next iPalette
End Function

'---------------------------------------------------------------------
Private Function BlackColorindex(oWB As Workbook)
'---------------------------------------------------------------------
Dim iPalette As Long
BlackColorindex = 0
For iPalette = 1 To 56
If oWB.Colors(iPalette) = &H0 Then
BlackColorindex = iPalette
Exit Function
End If
Next iPalette
End Function

'---------------------------------------------------------------------
Private Function DecodeColorIndex(rng As Range, _
text As Boolean, _
idx As Long)
'---------------------------------------------------------------------
Dim iColor As Long
If text Then
iColor = rng.font.ColorIndex
Else
iColor = rng.Interior.ColorIndex
End If
If iColor < 0 Then
iColor = idx
End If
DecodeColorIndex = iColor
End Function

'---------------------------------------------------------------------
' End of ColorIndex Function
'---------------------------------------------------------------------
بعدين لمعرفه ارقام الالوان في اكسل يجب عليك وضع اسم الداله السابقه في خليه وتحديد اسم الخليه التي تحتوي على اللون
مثلا يوجد لديك اللون الاصفر
قم بتعبئه خليه باللون الاصفر ولتكن مثلا a1
ثم اكتب هذه الداله في b1 مثلا
=ColorIndex(a1)

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

نفرض ان الخلاياالملونه موجوده في العمود e
نذهب الى الخليه المراد الجمع فيها للون الاصفر ونضع المعادله التاليه
=SUMPRODUCT(--(ColorIndex(E1:E100)=6),E1:E100)

حيث ان الرقم 6 هو اللون شرط الجمع
طبعا هذه الداله لا تجمع الخلايا الملون باستخدام التنسيق التلقائي

[naderwatfa]

أخي الكريم Bluemind

كل الشكر و التقدير لسرعة الرد على الأخ صاحب السؤال

ثم كل الشكر مرة ثانية عن نفسي

لأني محتاج هذا الكود

[يحيى حسين]

أخي هذا حل اخر لأخونا أبو اسامة العينبوسي

http://www.officena.net/ib/index.php?showtopic=27216

=================

و اذا كان الاوفيس لديك 2007

يمكنك استخدام الميزات الجاهزة التي توفرها النسخة الجديدة

[shshorbagy]

شاكرين الزملاء الكرام

جزاكم الله خيرا علي كل هذه الردود وسرعتها

الحل مناسب لي تماما

[جلال محمد]

الأخوة الكرام

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

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

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

ولكم الشكر ،،،،،

جمع الخلايا الملونه.rar

[جلال محمد]

الأخوه الكرام

السلام عليكم

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

[أ / محمد صالح]

الأخوة الكرام

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

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

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

ولكم الشكر ،،،،،

أخي الكريم جلال

لعمل المطلوب بالنسبة للتنسيق الشرطي يمكنك تحويل معادلة التنسيق الشرطي إلى دالة sumif

ففي مثالك يمكنك جمع الخلايا الملونة بالعمود h بهذه المعادلة

=SUMIF(H7:H20;"<8")

وفقني الله وإياكم لكل ما يحب ويرضى

[م/ مغترب]

السلام عليكم

 

هل هنالك دالة لذلك  ام  يجب أن يكون ماكرو 

 

ارجوا المساعدة بإرفاق ملف  جاهز لمعرفة الدالة واستخدامها

 

وشكرا