سيناريو تجميع خلايا في نطاق تعطي نتيجة رقم معطى

[عبدالله باقشير]

السلام عليكم

هو طلب لاحدهم وضعته هنا لعموم الفائدة

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

دائما نكون محتاجين عمودين بجانب النطاق
لوضع السيناريو
عنوان خلايا الجمع وحاصل نتيجة الجمع


غير معطياتك بداية الكود

 

Option Explicit
'''النطاق الذي تريد فحصه
Const rAddres As String = "B4:B12"
'''' خلية رقم الفحص
Const vAddres As String = "F3"

وهذا الكود

 

Option Explicit
'''النطاق الذي تريد فحصه
Const rAddres As String = "B4:B12"
'''' خلية رقم الفحص
Const vAddres As String = "F3"
Dim cd

Sub kh_Test()
Dim r%, rr%
cd = 8
With Range(rAddres)
	.Interior.ColorIndex = xlNone
	.Offset(0, 1).Resize(, 2).ClearContents
	.Cells(0, 2).Resize(1, 2).Value = Array("Addres", "Sum")
	For rr = 1 To .Rows.Count
		For r = rr To .Rows.Count
			SumTest .Cells, Union(.Cells(rr, 1), .Cells(r, 1)), Val(Range(vAddres))
		Next
	Next
End With
End Sub

Sub SumTest(MyRng As Range, TestCol As Range, MyVal As Double)
Dim iCol As Range, Adr$
With MyRng
	For Each iCol In .Cells
		If WorksheetFunction.Sum(Union(iCol, TestCol)) = MyVal Then
			If kh_tColor(Union(iCol, TestCol)) Then
				Adr = Union(iCol, TestCol).Address
				With .Offset(.Rows.Count, 1).End(xlUp).Offset(1, 0)
					.Resize(1, 2).Value = Array(Adr, "=SUM(" & Adr & ")")
				End With
				Union(iCol, TestCol).Interior.ColorIndex = cd
				cd = cd + 1
				Exit For
			End If
		End If
	Next
End With
End Sub

Function kh_tColor(Col As Range) As Boolean
Dim T As Range
For Each T In Col.Cells
	If T.Interior.ColorIndex = xlNone Then
		kh_tColor = True
		Exit For
	End If
Next
End Function

المرفق 2003
2007
حاصل جمع.rar

 

 

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

التحديث الاخير للكود  في 18-2-2015

المرفق 2010

 

سيناريو توافيق تجميع قيم تعطي نتيجة معينة.rar

[بن علية حاجي]

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

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

أخوك بن علية

[أبو آدم]

أبدعت عبدالله

نفع الله بك وبعلمك

............

[عبدالله باقشير]

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

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

أخوك بن علية

جزاك الله الف خير اخي الحبيب بن عليه

ولك اجر وثواب دعائك اضعاف مضاعفة

واكرمك الله بالصحة والعافية في الدنيا والاخرة

وامدك العلم الوفير في طاعته وخدمة عباده

تقبل تحياتي وشكري

[عبدالله باقشير]

أبدعت عبدالله

نفع الله بك وبعلمك

............

جزاك الله خيرا

وبارك الله فيك

تقبل تحياتي وشكري

[الـعيدروس]

السلام عليكم

جزاك الله الف خير استاذ عبدالله

تقبل مروري وفائق تحياتي وشكري

[عبدالله باقشير]

السلام عليكم

جزاك الله الف خير استاذ عبدالله

تقبل مروري وفائق تحياتي وشكري

وعليكم السلام

بارك الله فيك وجزاك خيرا

اخي ابو انصار

تقبل تحياتي وشكري

[عبدالله المجرب]

ما شاء الله

عمل مميز كعادتك

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

لكني وجدت الحل طويل ويحتاج الى تجارب كثيرة فتوقفت على امل المحاولة في الاجازة لكن مثل هذا الحل الابداعي لا اجد الا الدعاء لك بان يبارك الله لك في ما من به عليك من العلم

ما شاء الله لا زلنا في بداية الطريق نتعلم من اساتذة الاكسل فكل يوم نرى عجائب ابداعاتهم

[احمد عطية رزق]

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

[abcamir]

بارك الله فيكم استاذنا الكريم على هذا الموضوع الرائع

هل تحديد عدد القيم التي تساوي النتيجة المطلوبة ؟ مثلا 7 قيم تساوي النتيجة المطلوبة

مع الشكر و التقدير