طلب مجاميع بشرط واحد

[عمرو حسنى]

مجاميع.rar

			10	المجموع				او علي الشكل التالي			مع مراعاة عدم تكرار جمع نفس الرقم
A	1
B	2						مج1	1	2	3	4
C	3						مج2	2	3	5
D	4
E	5						مج4	5	4	1
F	6						مج5	6	4
المطلوب
	مجموعة بدائل الارقام التى مجموعها يساوى 10 اي الخليه d1
	واظهار هذه الارقام كما هى على شكل تلوينها مثلا بلون واحد كما هو موضح
		مع مراعاة عدم تكرار جمع نفس الرقم

تم تعديل سبتمبر 12, 2015 بواسطه عمرو حسنى

[ياسر خليل أبو البراء]

أخي الكريم عمرو حسني

كيف سيتم تلوين كل مجموعة خلايا بلون واحد وهناك تداخل في النتائج المتوقعة بشكل كبير ..؟؟

أقصد أن الطلب غير منطقي إذ أن الرقم الواحد قد يدخل في أكثر من احتمال ومن ثم سيكون هناك لبس شديد فيما يخص التلوين

يمكن الاعتماد على الجزء الآخر الذي أشرت إليه مج1 ومج2 وهكذا ...

 

ملحوظة : النتيجة 3    5    2    أليست هي نفس النتيجة  للاحتمال 2   3  5   (أعتقد أنه لا داعي للتكرار طالما أن نفس الأرقام تؤدي نفس النتيجة)

في انتظار الرد على الملاحظات التي أشرت إليها

[عمرو حسنى]

حضرتك عندك حق وشكرا على الرد 

فعلا المطلوب عدم تكرار المجموعة اذا اعطت نفس النتائج 

لكنى عاجز عن الحل بالفعل 

واذا كان التلوين معضليه مفيش مشكله انا عاوزها مجموعامنفصلة غير مكررة كما تفضلت

ت 

[ياسر خليل أبو البراء]

أخي الكريم عمرو حسني

إليك الكود التالي

Private iGblGoldenTotal As Long
Private iGblOutputRow As Long
Private iGblMatchingTotalCount As Long
Private Const nOutputHeaderROW = 2

Sub FindCombinationsAddingToGoldenTotal()
    Dim vElements As Variant
    Dim vresult As Variant
    Dim I As Long, T As Long
    Dim iLastIndex As Integer
    Dim sValue As String
    
    Sheets("Sheet1").Range("H3:Z" & Rows.Count).ClearContents
    
    iLastIndex = 0
    ReDim vElements(1 To 1)
    iGblGoldenTotal = Range("D1").Value
    
    For T = 2 To Cells(Rows.Count, "B").End(xlUp).Row
        sValue = Range("B" & T).Value
        If IsNumeric(sValue) Then
            iLastIndex = iLastIndex + 1
            ReDim Preserve vElements(iLastIndex)
            vElements(iLastIndex) = sValue
        End If
    Next T
    
    iGblOutputRow = nOutputHeaderROW
    iGblMatchingTotalCount = 0
    
    For I = 1 To UBound(vElements)
        ReDim vresult(1 To I)
        Call CombinationsNP(vElements, I, vresult, 1, 1)
    Next I
End Sub

Sub CombinationsNP(ByVal vElements As Variant, ByVal P As Long, ByRef vresult As Variant, ByVal iElement As Integer, ByVal iIndex As Integer)
    Dim I As Long
    Dim II As Long
    Dim iSum As Long
    
    For I = iElement To UBound(vElements)
        vresult(iIndex) = vElements(I)
        If iIndex = P Then
            iSum = 0
            For II = LBound(vresult) To UBound(vresult)
                iSum = iSum + vresult(II)
            Next II
            
            If iSum = iGblGoldenTotal Then
                iGblOutputRow = iGblOutputRow + 1
                
                iGblMatchingTotalCount = iGblMatchingTotalCount + 1
                Range("H" & iGblOutputRow).Value = "مج " & iGblMatchingTotalCount
                Range("I" & iGblOutputRow).Resize(, P) = vresult
            End If
        Else
            Call CombinationsNP(vElements, P, vresult, I + 1, iIndex + 1)
        End If
    Next I
End Sub

مرفق الملف فيه تطبيق الكود ..

تقبل تحياتي

Totals For All Combinations.rar

[عمرو حسنى]

الشكر كل الشكر للاخ الفاضل 

ياسر خليل أبو البراء

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

فتقل الملف ولم تفلح المحاولة 

وبالنهاية لكم منى جزيل الشكر

Totals For All Combinations (Autosaved).rar

Totals For All Combinations (Autosaved).rar

[ياسر خليل أبو البراء]

أخي الكريم عمرو

من الطبيعي أن يستغرق الكود وقت طويل جداً في حالتك إذ أن عدد الاحتمالات وعدد العمليات الحسابية التي سيقوم بها الكود ستكون كبيرة جداً جداً ..

عموماً ننتظر مساهمات الأخوة الأعضاء فلربما يكون هناك حل أفضل للتعامل مع هذا الكم من الأرقام