طلب المساعدة فى كود ماكرو لدمج الخلايا المختارة مع جمع قيمة الخلايا المدمجة

[عبدالرحمن بدوى]

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

بناء على نصيحة أخى وأستاذى الفاضل

ياسر خليل ابو البراء بعرض المطلوب جزء جزء لتتم الاستفادة

فهذه هى الجزئية الثانية

فى الملف المرفق شيت المبيعات أريد دمج الخلايا فى عمود (مجموع المبيعات اليومية) لكل يوم مبيعات منفردا مع جمع محتويات الخلايا المدمجة   

المطلوب هو كود ماكرو يقوم بدمج الخلايا المختارة وجمع محتوياتها بمجرد تظليلها

بمعنى انى سأقوم بتظليل الخلايا واستخدام الماكرو ويتم الدمج والجمع 

 

أو أن كان هذا ممكنا يقوم بمدج الخلايا وجمع محتوياتها بشكل اوتوماتيكى للخلايا ما بين الصفين المظللين بلون مختلف

بمعنى أن العملية ستتم بشكل اوتوماتيكى دون تدخل منى

 

مع العلم أن الصف الملون بلون مختلف هو تنسيق شرطى بناء على قيمة الخلية الأولى

 

وجزاكم الله خيرا 

ادارة المحل.rar

[الـعيدروس]

السلام عليكم

ربما فهمت طلبك

شوف الكود بيشيك على العمود "F" وبموجب الدمج الذي في العمود "F"

بيعمل مثله في العمود "J"  مع الاحتفاظ بقيم الخلايا المدموجه + جمعها

بمعنى اذا العمود "F" ليس به خلايا مدموجه لم ينفذ شيء الكود

جرب الكود

 

Sub Ali_Merg()
Dim Rng As Range
Dim Rm As Range
Dim My_r As Range
Dim X_r As Double
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
For Each Rng In Range("F6:F20")
  If Rng.MergeCells Then
  If Not Rng Is Nothing Then
     If Rm Is Nothing Then Set Rm = Rng.Offset(0, 4) Else Set Rm = Union(Rm, Rng.Offset(0, 4))
  End If
  End If
Next
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
If Not Rm Is Nothing Then
  For Each My_r In Rm.Areas
     X_r = Alr_Cn(My_r)
    With My_r
        .ClearContents
        .Merge
        .Value = X_r
    End With
     Debug.Print X_r
  Next
End If
Set Rng = Nothing: Set Rm = Nothing
Set My_r = Nothing
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
End Sub
Private Function Alr_Cn(R As Range) As Currency
 Dim i
 Dim Sm As Double
 With R
    For i = 1 To .Rows.Count
       Sm = Sm + .Cells(i, 1)
    Next i
       If Sm Then Alr_Cn = Sm
 End With
End Function

 

تحياتي

او هكذا حسب التحديد الحالي

يعني تضلل مثلا 5 سطور وتظغط كنترول وتضلل 5 سطور اخر  في العمود "J" وهكذا

وبعد التضليل شغل الكود

Sub Ali_Merg()
Dim My_r As Range
Dim X_r As Double
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
  For Each My_r In Selection.Areas
     X_r = Alr_Cn(My_r)
    With My_r
        .ClearContents
        .Merge
        .Value = X_r
    End With
  Next
Set My_r = Nothing
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
End Sub
Private Function Alr_Cn(R As Range) As Currency
 Dim i
 Dim Sm As Double
 On Error Resume Next
 With R
    For i = 1 To .Rows.Count
       Sm = Sm + .Cells(i, 1)
    Next i
       If Sm Then Alr_Cn = Sm
 End With
 On Error GoTo 0
End Function

 

[عبدالرحمن بدوى]

اخى وأستاذى العيدروس

جزاكم الله خيرا على المساعدة والإهتمام

الكود الثانى يعمل تمام جدا يقوم بالدمج والجمع للخلايا المختارة

اما الكود الأول فهو يعمل تمام جدا

ولكن لعلى لم أستطع بالضبط شرح ما أقصد

ماذا لو لم تكن الخلايا فى العمود المكتوب به التاريخ مدمجة 

فقد اعتمدت فى الكود على أنه فى خلايا مدمجة فسيقوم الكود بدمج نفس عدد الصفوف

وهى فكرة ممتازة لكن أنا أريده أن يعتمد مثلا على اختلاف اللون الذى أفصل به بين كل يوم والاخر

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

أو أى فكرة اخرى تمكننى من دمج الخلايا الخاصة بمبيعات كل يوم منفردا

وجزاكم الله خيرا مقدما

وآسف على الاطالة وكثرة الطلبات

ادارة المحل.rar

[الـعيدروس]

السلام عليكم

هل يوجد ضمن العمود A ايام غير محصوره بالنجمه *

يعني ايام عشوائيه ليست منسقه بالسطر الاخضر ؟

ام اكيد ان كل مجموعة سطور ليوم معين يلييها سطر اخضر

    الخلاصه جرب الكود التالي ينفذ لك الدمج حتى اخر خليه في العمود A

    بها نجمه

Sub Ali_Merg_Data()
Dim R As Range
Dim Rng As Range
Dim My_r As Range
Dim X_r As Double
On Error Resume Next
For Each R In Range("A6:A" & Ali_Last(Range("A6:A2000"), "*"))
If R <> "*" Then
    If Not R Is Nothing Then
       If Rng Is Nothing Then Set Rng = R Else Set Rng = Union(Rng, R)
    End If
End If
Next R
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
If Not Rng Is Nothing Then
  For Each My_r In Rng.Offset(0, 9).Areas
     X_r = Alr_Cn(My_r)
    With My_r
        .ClearContents
        .Merge
        .Value = X_r
    End With
  Next
End If
On Error GoTo 0
Set Rng = Nothing: Set R = Nothing
Set My_r = Nothing
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
End Sub
Private Function Alr_Cn(R As Range) As Currency
 Dim i
 Dim Sm As Double
 With R
    For i = 1 To .Rows.Count
       Sm = Sm + .Cells(i, 1)
    Next i
       If Sm Then Alr_Cn = Sm
 End With
End Function
Private Function Ali_Last(Rnge As Range, F_Tx$)
Dim vv
Application.ScreenUpdating = False
    For vv = Rnge(Rnge.Count).Row To Rnge(1).Row Step -1
        If Cells(vv, Rnge.Column) = F_Tx Then
            Ali_Last = vv
            Exit Function
        End If
    Next vv
Application.ScreenUpdating = True
End Function

 

[عبدالرحمن بدوى]

أستاذى الفاضل العيدروس

أولا جزاكم الله خيرا

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

وبالضبط هذا التعديل هو الذى أريده تحديدا

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

لو أردت تغيير عمل الكود مثلا ليعمل على العمود F فأين أستطيع تغيير ذلك

وماذا لو أردت الكود يقوم بتنفيذ الدمج فى أكثر من عمود وليكن F,i , j فأين يكون التعديل

وجزاكم الله خيرا للمرة الثانية

 

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

[الـعيدروس]

السلام عليكم

اذا لم يتغير عمود الذي به النجمه

  سهل ارفق الملف وبه الاضافات التي تريدها مع شرح مبسط

وابشر ان شاء الله خير

تحياتي

[عبدالرحمن بدوى]

أخى الفاضل جزاكم الله خيرا على هذا المجهود

وجعله الله فى ميزان حسناتك يوم القايمة

"خير الناس أنفعهم للناس"

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

وهى كالتالى

أولا أريد أن يتم تنفيذ الجمع فى ثلاثة أعمدة وليس عمود واحد فقط 

ثانيا أريد مسح محتويات الصف المكتوب به النجمة

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

أريد ايضا أنه مع التلوين يتم مسح محتويات الخلايا فى باقى الصف

ايا كان ذلك من خلال التعديل على التنسيق الشرطى نفسه أو الغاؤه وعمل ذلك من خلال ماكرو

ثالثا أريد أيضا (إن أمكن) أن يتم كل ذلك بشكل تلقائى دون التدخل منى نهائيا

بمعنى أن يتم الدمج والجمع للخلايا بمجرد ضغط النجمة 

حيث أنه بمجرد الضغط على النجمة يكون ذلك معناه نهاية مبيعات اليوم وبداية يوم جديد

فيتم تلوين الصف بلون أخضر ومسح محتوياته

وبعد ذلك يتم جمع دمج وجمع الخلايا المشار اليها مسبقا بشكل اوتوماتيكى

 

 

طبعا انا عارف انى طولت وأثقلت علي حضرتك بالطلبات

وانا عارف أنك نفسك تقول" ايه الى جاي يحقق احلامه عندنا ده

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

وللأسف الشديد انى لا أستطيع ان افيد أحد بشئ فى المنتدى لقلة خبرتى فى الاكسيل

وجزاكم الله خيرا

ادارة المحل.rar

[عبدالرحمن بدوى]

اخوان الافاضل هل من مساعد فى الكود السابق

فانا احتاج هذاالتعديل ضرورى قدر الإمكان

[الـعيدروس]

 

اقتباس

أريده بالضغط على زرار الماكرو أن يقوم بتنفيذ الدمج والجمع على الأعمدة  معا F,I,h

جرب هذا التعديل

Sub Ali_Merg_Data1()
Dim R As Range
Dim Rng As Range
Dim My_r As Range
Dim X_r As Double
Dim Ing As Variant
On Error Resume Next
For Each R In Range("A6:A" & Ali_Last(Range("A6:A2000"), "*"))
If R <> "*" Then
    If Not R Is Nothing Then
       If Rng Is Nothing Then Set Rng = R Else Set Rng = Union(Rng, R)
    End If
End If
Next R
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
If Not Rng Is Nothing Then
 For Each Ing In Split(Ali_My_Rng(Rng.Offset(0, 5), Rng.Offset(0, 7), Rng.Offset(0, 8)), ",")
    Set My_r = Range(Ing)
    X_r = Alr_Cn(My_r)
    With My_r
        .ClearContents
        .Merge
        .Value = X_r
    End With
  Next
End If
On Error GoTo 0
Set Rng = Nothing: Set R = Nothing
Set My_r = Nothing
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
End Sub
Private Function Alr_Cn(R As Range)
 Dim i
 Dim Sm
 Dim Sn As String
 With R
    For i = 1 To .Rows.Count
       If Not IsNumeric(.Cells(i, 1)) Then
           Sm = .Cells(1, 1)
          Else
           Sm = Sm + .Cells(i, 1)
       End If
    Next i
       If Sm Then Alr_Cn = Sm
 End With
End Function
Private Function Ali_Last(Rnge As Range, F_Tx$)
Dim vv
Application.ScreenUpdating = False
    For vv = Rnge(Rnge.Count).Row To Rnge(1).Row Step -1
        If Cells(vv, Rnge.Column) = F_Tx Then
            Ali_Last = vv
            Exit Function
        End If
    Next vv
Application.ScreenUpdating = True
End Function
Private Function Ali_My_Rng(ParamArray Rngs() As Variant) As String
        Dim N As Long
        Dim R As Range
        Dim T As String
        For N = LBound(Rngs) To UBound(Rngs)
            If Not Rngs(N) Is Nothing Then
                For Each R In Rngs(N).Areas
                        T = T & "," & R.Address
                Next R
            End If
        Next N
         Ali_My_Rng = Mid(T, 2, Len(T))
End Function

 

[عبدالرحمن بدوى]

أشكرك أخى الفاضل على المساعدة