تحديد "تضليل " الخلايا التي تحتوي على اعداد تساوي مجموع ما

[قلم-الاكسل(عبدالعزيز)]

السلام عليكم

هذا الملف المرفق يحتوي على المطلوب لكن لا اعرف المعادلات والصيغ اللازمة لذلك قمت بالبحث في الموقع ووجدت العبقري بن علية قد فعل ذلك في مشاركة له لكن تلك المشاركة يجب أن تكون الأعداد في نفس العمود لكي يتم معرفة الاعداد التي تضم مجموعا ما .. وأنا مختلف قليلا حيث ان بدل العمود وضعت صفوفا وهي أربعة صفوف فعندما أدخل مجموع معين في المربع المشار اليه في الملف المرفق فإن الإكسل يقوم تلقائيا بتحديد"تلوين" الخلايا التي تحتوي على العدد في المجموع في الصفوف الأربعة ::

ولا يجب أن يكون المجموع اعداده من كل الصفوف الأربعة ربما يكون الاعداد من صفين او من ثلاثة صفوف .. المهم أن الفكرة وصلت مع ان برمجة "سيدي وشيخنا الفذ العبقري المهندس بن علية " فوق الممتازةوفيها ابداع

وان قام وتفضل هو بنفسه او احد من الموقع بعمل مثله لما طلبته في الملف المرفق سأكون له شاكرا ولربي له سائلا وداعيا

وهذا ملفي والفكرة التي يحملها بعنوان مجموع البحث الجديد :

 

وهذا رابط مشاركة المهندس بن علية

وهذا ملف مشاركة بن علية لمن اراد التعديل عليه كما طلبته تفضلا من الجميع بالمساهمة المبدعة والتي تعودناها من المحترفين والمبدعين وملف م/بن علية اسمه "نموذج جمع خليتين"

مجموع البحث الجديد.rar

نموذج جمع خليتين.rar

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

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

أخي الكريم عبد العزيز، هذه المرة لم أقم بتلبية طلبك المتمثل في تضليل الخلايا من كل صف والتي مجموعها يساوي قيمة "مجموع البحث" بل قمت بتركيب كود (كلاسيكي ليس مثلما يقدمه الإخوة المتمكنين من الأكواد) يقوم بجلب عناوين الخلايا من كل صف لكل الحالات الممكنة التي يتوفر فيها المطلوب... (ربما يكون الكود بطيئا في العمل -هذا حال المبتدئين-)... أرجو أني فهمت المطلوب وقربت المفهوم... قم بوضع مجموع البحث في الخلية المعنية والضغط على الزر "TEST" (وانتظر بعض الوقت...)...

أخوك بن علية

 

مجموع البحث الجديد.rar

تم تعديل يناير 4, 2016 بواسطه بن علية حاجي

[قلم-الاكسل(عبدالعزيز)]

السلام عليكم سيدنا وعزيزنا وشيحنا واستاذنا ومبدعنا المهندس بن علية أعلاك الله العلي في ارضه وسمواته ..

السلام عليكم كل المراقبين والمشرفين والخبراء والأعضاء

لا اعرف كيف اشكرك (المهندس بن علية) ولا استطيع اا ان اعبر بخالص اعجابي الشديد في ابداعاتك المتواصلة مع كثرة شغلك ومشاغلك

فعلا هو المطلوب جزاك الله عني وعن كل المستخدمين كل الخيرات .

حفظك الله من كل سوء وشر وعافاك ربنا المعافي من كل بلاء واسعدك الله دنيا واخرى .

ورزقك الله الرزاق رزقا مبارك مدرارا لا فقر بعدها أبدا وانعم عليك بنعم لا تحصى لا نقم فيها ولا بلاء عليها  وأعطاك راحة لا نكد بعدها وسعادة لا شقاء بعدها وصحة ملائكية وأنوارا سماوية وحفظك الله وبارك لك وفي أهلك وكل من تحب. آمين الى يوم الدين بحق سيد النبيين

 

 

[مختار حسين محمود]

السلام عليكم 

أستاذى الفاضل بن عليه 

كل عام و أنت أقرب الى الله

رغم بط ء الكود ( بسبب الحلقات التكرارية ) الا انه كود ذكى بجد وفعال فى آداء  وظيفته

أشكرك بجد على هذه الهدية الثمينة .  أخوك و تلميذك مختار

 

تم تعديل يناير 5, 2016 بواسطه مختار حسين محمود

[مختار حسين محمود]

السلام عليكم

أستاذى بن عليه أثناء تجربتى لمرفق حضرتك وجدت الآتى :

اذا وضعت مكونات العدد 100  ( 15 و 5 و  50 و 30 ) مثلا فى ال 4 صفوف 

و حذفت الكلمات الصف أ  و الصف ب  ...... الخ التى بأول كل صف  فان الكود لا يعطى شيئا

هذا دفعنى للعمل على الكود و تعديله بالكيفية الآتيه :

الاستغناء عن كل التسميات فى المرفق والتى تزيد من بطء الكود

و التعويض عنها بنطاقات فى الكود نفسه وهذا من شأنه اعطاء الكود مرونة وسرعة  .

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

Sub TEST2()
' Find every combination H.ben & Mokhtar 5/1/2015
Dim i As Integer

Dim Adrs1 As String, Adrs2 As String, Adrs3 As String, Adrs4 As String
Dim C1 As Range, C2 As Range, C3 As Range, C4 As Range, MyCel As Range
Dim Rng1 As Range, Rng2 As Range, Rng3 As Range, Rng4 As Range

i = 16
Set MyCel = Sheets("Sheet1").Range("E12")
Set Rng1 = Sheets("Sheet1").Range(Range("B3"), Cells(3, Cells(3, Columns.Count).End(xlToLeft).Column))
Set Rng2 = Sheets("Sheet1").Range(Range("B5"), Cells(5, Cells(5, Columns.Count).End(xlToLeft).Column))
Set Rng3 = Sheets("Sheet1").Range(Range("B7"), Cells(7, Cells(7, Columns.Count).End(xlToLeft).Column))
Set Rng4 = Sheets("Sheet1").Range(Range("B9"), Cells(9, Cells(9, Columns.Count).End(xlToLeft).Column))

On Error Resume Next

With Application
        .ScreenUpdating = False: .DisplayAlerts = False: .Calculation = xlCalculationManual
End With

Sheets("Sheet1").Range(Cells(16, 2), Cells(Rows.Count, 6)).ClearContents


For Each C1 In Rng1
    Adrs1 = C1.Address
          For Each C2 In Rng2
              Adrs2 = C2.Address
                     For Each C3 In Rng3
                         Adrs3 = C3.Address
                               For Each C4 In Rng4
                                   Adrs4 = C4.Address
           If C1 + C2 + C3 + C4 = MyCel Then
              Cells(i, 2) = i - 15
              Cells(i, 3) = Adrs1
              Cells(i, 4) = Adrs2
              Cells(i, 5) = Adrs3
              Cells(i, 6) = Adrs4
              i = i + 1
           End If
      Next
    Next
  Next
Next

On Error GoTo 0

Set MyCel = Nothing
Set Rng1 = Nothing
Set Rng2 = Nothing
Set Rng3 = Nothing
Set Rng4 = Nothing

With Application
       .ScreenUpdating = True: .DisplayAlerts = True: .Calculation = xlCalculationAutomatic
End With
    
End Sub

تحياتى لك من قلبى سيدى الفاضل الخلوق .     و السلام عليكم

Find every combination H.ben & Mokhtar.rar

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

أخي الغالي المتميز مختار

بارك الله فيك وجزيت خيراً على هذا الإبداع

أخي وحبيبي في الله بن عليه حاجي

جزيت خير الجزاء على شرارة الإنطلاق الإبداعية

 

إليكم إثراءً للموضوع الكود التالي

Sub FindCombinations()
    Dim V(1 To 4) As Variant, W(1 To 4) As Variant, P As Variant
    Dim PCount&, I&, II&, III&, IIII&
    Dim Target As Single, Cell As Range
    
    ReDim P(1 To 4, 1 To 1)
    
    For I = 1 To 4
        With Union([Ligne_1], [Ligne_2], [Ligne_3], [Ligne_4]).Areas(I)
            V(I) = .Value
            W(I) = .Value
            II = 0
            For Each Cell In .Cells
                II = II + 1
                W(I)(1, II) = Cell.Address
            Next Cell
        End With
    Next I
    
    Target = [Cellule1].Value
    
    For I = 1 To UBound(V(1), 2)
        For II = 1 To UBound(V(2), 2)
            For III = 1 To UBound(V(3), 2)
                For IIII = 1 To UBound(V(4), 2)
                    If Target = V(1)(1, I) + V(2)(1, II) + V(3)(1, III) + V(4)(1, IIII) Then
                        PCount = PCount + 1
                        ReDim Preserve P(1 To 4, 1 To PCount)
                        P(1, PCount) = W(1)(1, I)
                        P(2, PCount) = W(2)(1, II)
                        P(3, PCount) = W(3)(1, III)
                        P(4, PCount) = W(4)(1, IIII)
                    End If
                Next IIII
            Next III
        Next II
    Next I
    
    Application.ScreenUpdating = False
        [B16:F65000].ClearContents
        [C16:F16].Resize(PCount).Value = Application.Transpose(P)
        [B16].Value = 1
        [B16].Resize(PCount).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Trend:=False
    Application.ScreenUpdating = True
End Sub

تقبلوا تحياتي

 

Find Every Combination YasserKhalil.rar

[مختار حسين محمود]

  [C16:F16].Resize(PCount).Value = Application.Transpose(P)

بارك الله فيك أستاذى الغالى ياسر و جزيت خيرا بلا شك الكود رائع و سريع حتى مع وجود التسميات

التى كنت أظن أنها تساهم فى بطء الكود الذى تفضل به أستاذنا الرائع الخلوق بن عليه

لكن  جربت  الأرقام 1و2 و 3 و4 فى الأربع صفوف  وبحث عن الرقم 10 و الكود توقف فى هذا السطر  تحديدا    رقم الخطأ 1004

 

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

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

جربت وضع الأرقام 1 و 2 و 3 و 4 في الأربعة صفوف .. ولم يحدث معي خطأ

ارفق الملف مع التعديل الذي قمت به للإطلاع عليه ...

ملحوظة : التسميات مستخدمة في الكود

 

[مختار حسين محمود]

أستاذى الغالى  لم أقم بأية تعديلات  سوى اضافة الأرقام فقط

وهذه صورة  للخطأ 

 

 

تم تعديل يناير 6, 2016 بواسطه مختار حسين محمود

[قلم-الاكسل(عبدالعزيز)]

3 ساعات مضت, مختار حسين محمود said:

أستاذى الغالى  لم أقم بأية تعديلات  سوى اضافة الأرقام فقط

وهذه صورة  للخطأ 

 

 

حياك الله عزيزنا مختار جعلك الله من المختارين

هو فعلا من 1 الى 99 لا يظهر النتائج وتظهر نافذة الخطأ التي تفضلت بها  وتظهر النتائج بداية من العدد 100

مع انه كود سريع جدا ولا يعلق الاكسل اثناء البحث عن النتائج لسرعة ظهور النتائج

ونشكر المهندس ياسر الجليل

 

 

تم تعديل يناير 6, 2016 بواسطه قلم-الاكسل(عبدالعزيز)

[قلم-الاكسل(عبدالعزيز)]

اشكر الاساتذة المحترمين والمهندسين المبدعين

م/بن علية وم/ياسر وم/مختار لإثرائهم الموضوع مع ان موضوعي هو بداية لفكرة ما وسأطرحها في موضوع مستقل مرتبط بموضوع سابق وهذا الموضوع الحالي ..

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