مطلوب كود لمعرفة حاصل جمع قيم خلايا من نطاق محدد للحصول على رقم مدخل

[الحامد الشاكر]

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

تحية طيبة وبعد

يرجى فتح الملف المرفق والذي يشرح الطلب

مع قبول فائق الإحترام

حاصل جمع.zip

[ابو تميم]

لقد ضعنا أخي الكريم

أين هو السؤال بالضبط

ما هو المطلوب

أرجو توضيح السؤال أكثر

هل المطلوب كما حللته كما يلي

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

تم تعديل مارس 11, 2012 بواسطه ابو تميم

[الحامد الشاكر]

السيد أبو تميم المحترم

بالضبط هذا هو القصد ولك جزيل الشكر

[الحامد الشاكر]

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

يرجى المساعدة

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

السلام عليكم

لكن قد يكون هناك اكثر من سيناريو

عموما تفضل الكود كبداية تصور

لمقارنة خليتين كحد اعلى

ده كود على السريع

Sub kh_Test()

Dim c As Range, co As Range

Range("F4:F12").Interior.ColorIndex = xlNone

For Each c In Range("F4:F12").Cells

	If Val(c) = Val([i3]) Then

		c.Interior.ColorIndex = 15: Exit For

	End If

	For Each co In Range("F4:F12").Cells

		If Intersect(c, co) Is Nothing Then

			If WorksheetFunction.Sum(Union(c, co)) = Val([i3]) Then

				Union(c, co).Interior.ColorIndex = 15

				Exit For

			End If

		End If

	Next

Next

End Sub

[الحامد الشاكر]

الأخ خبور المحترم

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

ولطفاً إرفاق الملف متضمناً الكود

مع فائق الإحترام

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

السلام عليكم

اولا لا تنسى تمكين الماكرو

وايضا

دائما نكون محتاجين عمودين بجانب النطاق

لوضع السيناريو

عنوان خلايا الجمع وحاصل نتيجة الجمع

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

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

[الحامد الشاكر]

سلمت يداك أخي خبور الرائع

جعله الله في ميزان حسناتك

ولكن ممكن أن تتطلع على المرفق والغريب أنه عند تغيير قيم الخلايا وإختيار الرقم 30 لم يتم يعطي نتيجة بالرغم من وجود سيناريو يحقق الرقم المدخل "30"

مع فائق الإحترام

حاصل جمع 1.zip

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

السلام عليكم

نعم كلامك صحيح

يحتاج تكرار الامر على نطاق واسع

برضه ابعدت الالوان لانها تتراكب فوق بعضها

Option Explicit

'''النطاق الذي تريد فحصه

Const rAddres As String = "B4:B12"

'''' خلية رقم الفحص

Const vAddres As String = "F3"

Sub kh_Test()

Dim r%, rr%

With Range(rAddres)

    .Cells(0, 2).Resize(1, 2).Value = Array("Addres", "Sum")

    With .Cells(1, 2).Resize(1, 2)

        Range(.Cells, .Cells.End(xlDown)).ClearContents

    End With

    For rr = 1 To .Rows.Count

        For r = rr To .Rows.Count

            SumTest .Cells, Range(.Cells(rr, 1), .Cells(r, 1)), Val(Range(vAddres))

            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

            Adr = Union(iCol, TestCol).Address

            With Cells(Rows.Count, .Column + 1).End(xlUp).Offset(1, 0)

                If WorksheetFunction.CountIf(Columns(.Column), Adr) = 0 Then

                    .Cells(1, 1).Formula = Adr

                    .Cells(1, 2).Formula = "=SUM(" & Adr & ")"

                End If

            End With

        End If

    Next

End With

End Sub

شاهد المرفق للتجربة

2003

سيناريو التجميع 2.rar

[الحامد الشاكر]

سلمت يداك وجعلها الله في ميزان جسناتك ويسر لك أمورك