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

[عاشق الاكسيل]

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

لو سمحت لو عندى مثلا 10 ارقام فى عمود معين فرضا من A1:A10 على سبيل المثال بالترتيب

5 - 9 - 16 -58 - 2- 6 - 8 - 90 -4 -10

ومثلا عاوز اعرف مجموع مين من الارقام دى يساوي رقم فى خلية تانية وليكن 60 فيبقي مثلا 2 و 58

او مثلا 34 يبقى 5 -9 - 2 -6 -8 -4

في طريقة تحقق ده بحيث يتم تظليل او تحديد القيم المطلوبة

[محمد هشام.]

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

اعتقد اخي الفاضل ان انسب طريقة لدالك هي استخراج القيم التي يساوي مجموعها القيمة المدخلة في عمود مغاير لان الاعتماد على التظليل ممكن يسبب لك تداخل في النتائج المتوقعة

عند تواجد نفس الرقم في اكثر من احتمال 

مثال لو اردنا استخراج الاعداد الخاصة ب 34  مع وجود الارقام التي قمت بدكرها في مشاركتك  سنعثر على نفس الارقام مكررة في اكثر من احتمال 👇

لتتفادى هدا ممكن استخدام الدالة التالية 

مثال لعملية استخراج القيم المتوقعة 👈  

 

لنفترض ان الخلية المخصصة لادخال المجموع هي B2

In cell B2

=IFERROR(TRANSPOSE(xFormula(A2:A11; B2));"")

وفي Module انسخ الكود التالي مع حفظ الملف بصيغة الماكرو 

Option Explicit
'================29/06/2024     by:MOHAMEED HICHAM    www.officena.net     "منتدى الاكسيل" '
'===========================================================================================
Public Function xFormula(rngNumbers As Range, XSum As Long)
Dim arNumbers() As Long, tmp() As Long, arr() As String, F As Range, Cnt As Long
    ReDim arr(0)
    If rngNumbers.Count > 1 Then
      ReDim arNumbers(rngNumbers.Count - 1)
      Cnt = 0
      For Each F In rngNumbers
          arNumbers(Cnt) = CLng(F.Value)
          Cnt = Cnt + 1
      Next F
      Call Cpt(arNumbers, XSum, tmp(), arr())
  End If
  ReDim Preserve arr(0 To UBound(arr) - 1)
  xFormula = arr
End Function
Private Sub Cpt(Numbers() As Long, target As Long, tmp() As Long, ByRef arr() As String)
    Dim s As Long, i As Long, j As Long, num As Long
    Dim Rng() As Long, tmpRec() As Long, n As Long
    s = a(tmp)
    If s = target Then
       n = UBound(arr)
       ReDim Preserve arr(0 To n + 1)
       arr(n) = b(tmp)
    End If
    If s > target Then Exit Sub
    If (Not Not Numbers) <> 0 Then
        For i = 0 To UBound(Numbers)
            Erase Rng()
            num = Numbers(i)
            For j = i + 1 To UBound(Numbers)
                Total Rng, Numbers(j)
            Next j
            Erase tmpRec()
            C tmpRec, tmp
            Total tmpRec, num
            Cpt Rng, target, tmpRec, arr
        Next i
    End If
End Sub
Private Function b(x() As Long) As String
    Dim n As Long, result As String
    result = " " & x(n)
    For n = LBound(x) + 1 To UBound(x)
        result = result & "-" & x(n)
    Next n
    result = result & " "
    b = result
End Function
Private Function a(x() As Long) As Long
    Dim n As Long
    a = 0
    If (Not Not x) <> 0 Then
        For n = LBound(x) To UBound(x)
            a = a + x(n)
        Next n
    End If
End Function
Private Sub Total(arr() As Long, x As Long)
    If (Not Not arr) <> 0 Then
        ReDim Preserve arr(0 To UBound(arr) + 1)
    Else
        ReDim Preserve arr(0 To 0)
    End If
    arr(UBound(arr)) = x
End Sub
Private Sub C(destination() As Long, source() As Long)
    Dim n As Long
    If (Not Not source) <> 0 Then
        For n = 0 To UBound(source)
                Total destination, source(n)
        Next n
    End If
End Sub

ادا كنت تستخدم النسخ الحديثة من الاوفيس ضع المعادلة التالية  في الخلية E2 للتحقق من مجموع القيم المستخرجة مع سحبها للاسفل 

=IF(D2<>"";SUM(FILTERXML("<x><y>"&SUBSTITUTE(TRIM(CONCAT(IFERROR(0+MID(D2;SEQUENCE(LEN(D2));1);" ")));" ";"</y><y>")&"</y></x>";"//y"));"")

 

فحص مجموعة قيم لايجاد اى منها يساوى قيمة معينة.xlsm

[mahmoud nasr alhasany]

ممتاذ احسنت استاذ / محمد هشام