جمع الارقام بناء على معيار معين فى الصف

[Ahmed.Hussein]

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

عندي معيار لا ادري كيف تطبيقه  كما بالمرفق 

شكرا للاهتمام .

المطلوب.xlsx

[سليم حاصبيا]

جرب هذا الماكرو

Option Explicit

Sub my_sum()
Dim Main_Rg  As Range, Cel As Range
Dim All_Rows%, i%, s#, t%

Set Main_Rg = Range("a3", Range("a2").End(4)).Resize(, 14)
 All_Rows = Main_Rg.Rows.Count
 i = 1
    Do Until i = All_Rows + 1
            For Each Cel In Main_Rg.Rows(i).Cells
                If Cel.Interior.ColorIndex <> xlNone Then
                    t = t + 1
                    s = s + IIf(IsNumeric(Cel), Cel, 0)
                End If
            Next Cel
       Cells(i + 2, 17) = t: t = 0
       Cells(i + 2, 15) = s: s = 0
       i = i + 1
   Loop
End Sub

الملف مرفق

 

 

matloub.xlsm

[Ali Mohamed Ali]

أحسنت أستاذ سليم كود ولا احسن ولا أروع -بارك الله فيك

[Ahmed.Hussein]

الاستاذ سليم 

شكرا جزيلا على المجهود - وبجد بجد انا ممنون جدا على المساعدة - بس يوجد مشكله صغيره ان  معاير الجمع ممكن تتغير ممكن يكون 1 او 2 او 3 على حسب وايضا احيانا التكالف بتتغير - كده الكود ثابت --  لو فيه طريقة غير ال VBA اتمنى ولو لا يوجد برجاء حل المشكلة لانى ليس على دراية بالVBA 

شكرا 

تم تعديل يوليو 17, 2019 بواسطه ahmed_hissen

[سليم حاصبيا]

يا سيدي المعادلات لا ترى الا محتوى الخلية ولا تنظر ابداً الى تنسيقها او لون الخط فيها او اي شيء في مظهرها الخارجي

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

بالنسبة لمعايير الجمع الكود يقوم بذلك ويدرج لك اوتوماتيكياً عدد الخلايا الملونة

 

[Ahmed.Hussein]

استاذ سليم . حضرتك انا في المثال لم اذكر انى عايز اجمع الوان خالص بالعكس .

شكر اليك .

[سليم حاصبيا]

ارفع مثالاً يحتوي عما تريد بالضبط (النتائج المتوقعة)

[Ahmed.Hussein]

حضرتك - ستجد فى الملف المطلوب جمع الرواتب بناء على معيار عدد الرواتب المطلوب جمعها 

شكرا للاهتمام

المطلوب.xlsx

ايضا فى حاله تغير عدد الرواتب المطلوب اعطاءها يتم جمع الراتب الى بعده 

[سليم حاصبيا]

الكود المطلوب لهذه الحالة

Option Explicit
Sub my_sum_New()
Dim i%, s#, j%, m%, k%
k = Cells(1, Columns.Count).End(1).Column - 2
Range(Cells(2, k + 1), Cells(1, k + 1).End(4)).ClearContents
 i = 2
    Do Until Range("A" & i) = vbNullString
       For j = 2 To k
         If Cells(i, j) <> "" And Cells(i, j) <> 0 Then
            s = s + IIf(IsNumeric(Cells(i, j)), Cells(i, j), 0)
            m = m + 1
         If m + 1 > Cells(i, k + 2) Then Exit For
        End If
      Next
      Cells(i, k + 1) = s: s = 0: m = 0
    i = i + 1
    Loop
End Sub

الملف مرفق

 

 

Matlob_1.xlsm

[Ahmed.Hussein]

هو دا الكلام VBA  تسلم ايدك

لو حبيت اغير عدد الاعمده مثلا من عمود Q الى عمود Aq والناتج يظهر فى عمود Af   

ازاى حضرتك 

تم تعديل يوليو 19, 2019 بواسطه ahmed_hissen

[سليم حاصبيا]

1 ساعه مضت, ahmed_hissen said:

هو دا الكلام VBA  تسلم ايدك

لو حبيت اغير عدد الاعمده مثلا من عمود Q الى عمود Aq والناتج يظهر فى عمود Af   

ازاى حضرتك 

الكود يقوم بهذا ايضاً

لكن النتيجة تكون في العامود  (ما  قبل الاخير) العامود AP

[Ahmed.Hussein]

صحيح الكود شغال لكن فى حاله ان الخلايا فاضيه بعد الترحيل العواميد  اما لو فيها اسامي الموظفيناو اى text  فيجمع صفر 

عموما لو ما فيها حل انا بشكرك جدا جدا جدا على تعبك ومجهودك الاكثر من رائع

Matlob_1 - Copy.xlsm

[سليم حاصبيا]

2 دقائق مضت, ahmed_hissen said:

صحيح الكود شغال لكن فى حاله ان الخلايا فاضيه بعد الترحيل العواميد  اما لو فيها اسامي الموظفيناو اى text  فيجمع صفر 

كيف يمكنك ان تجمع اسم موظف او اي نص مع رقم

مثلاً على ماذا تحصل اذا كتبت هذه الممعادلة   (سامي + 15+ محمد +25)

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

Option Explicit
Sub my_sum_New_with_color()
Dim i%, s#, j%, m%, k%
k = Cells(1, Columns.Count).End(1).Column - 2
Range(Cells(2, k + 1), Cells(1, k + 1).End(4)).ClearContents
Range(Cells(2, 1), Cells(1, k).End(4)).Interior.ColorIndex = xlNone
 i = 2
    Do Until Range("A" & i) = vbNullString
       For j = 2 To k
         If Cells(i, j) <> "" And Cells(i, j) <> 0 Then
            s = s + IIf(IsNumeric(Cells(i, j)), Cells(i, j), 0)
            m = m + 1
            Cells(i, j).Interior.ColorIndex = 6
         If m + 1 > Cells(i, k + 2) Then Exit For
                  
        End If
      Next
      Cells(i, k + 1) = s: s = 0: m = 0
    i = i + 1
    Loop
End Sub

 

[Ahmed.Hussein]

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

Matlob_1 - Copy.xlsm

[سليم حاصبيا]

تم تعديل الكود ليتناسب مع ما تريد

Option Explicit
Sub My_Sum_New_With_Empty()
Dim i%, s#, j%, m%, k%
k = Cells(1, Columns.Count).End(1).Column - 2

Range(Cells(2, k + 1), Cells(1, k + 1).End(4)).ClearContents
Range(Cells(2, 1), Cells(1, k).End(4)).Interior.ColorIndex = xlNone
 i = 2
    Do Until Range("A" & i) = vbNullString
       For j = 2 To k
           If Cells(i, j) = "" Or _
        Not IsNumeric(Cells(i, j)) Or _
        Cells(i, j) = 0 Then GoTo Next_J
            s = s + Cells(i, j)
            m = m + 1
            Cells(i, j).Interior.ColorIndex = 6
        If m = Cells(i, k + 2) Then Exit For

Next_J:
      Next
      Cells(i, k + 1) = s: s = 0: m = 0
    i = i + 1
    Loop
End Sub

الملفق من جديد

 

Matlob_2_with_empty .xlsm

[Ahmed.Hussein]

بجد بجد ما اعرف اشكرك ازى -- فعلا انت استاذ 

[سليم حاصبيا]

1 دقيقه مضت, ahmed_hissen said:

بجد بجد ما اعرف اشكرك ازى -- فعلا انت استاذ 

بسرعة الاعجاب + أفضل جواب