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

[محمد عبد الناصر]

محتاج في الملف المرفق كود يجمع الخلايا بشرط

يجمع الخلايا المدمجه مع بعض والخلايا المنفرده لوحدها الملف المرفق موضح المطلوب 

hg.xlsx

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

جرب هذا الملف صفحة Salim

Option Explicit

Sub sum_merged_cells()
If ActiveSheet.Name <> "Salim" Then Exit Sub
Dim Rg As Range
Dim Ro%, X%, m%
Dim t%, y%, s#, k%, Roc%
Ro = Cells(Rows.Count, 2).End(3).Row
Roc = Cells(Rows.Count, 3).End(3).Row
 With Range("E4").CurrentRegion
  .UnMerge
  .Clear
End With
 For X = 4 To Ro
    If Cells(X, 2).MergeCells = True Then
        t = Cells(X, 2).MergeArea.Rows.Count
        k = X
          For y = 1 To t
             s = s + Cells(k, 3).Offset(y - 1)
          Next
       Cells(k, 5).Resize(y - 1).Merge
       Cells(k, 5) = s
       s = 0
       X = X + y - 2
   Else
       Cells(X, 5) = Cells(X, 3)
   End If
 Next X
   
   With Range("E4:E" & Roc)
   .VerticalAlignment = 2
   .HorizontalAlignment = 3
   .Borders.LineStyle = 1
   .Font.Size = 18
   .Font.Bold = True
   End With
End Sub

الملف مرفق

Abd_naser.xlsm

[محمد عبد الناصر]

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

اخر طلب اخي اريد ان يكتب معادلة 
sum 

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

ويقوم بعمل الامر في العمود 

d 1

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

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

Option Explicit
Sub Sum_Merged_Cells_By_Formula()
    Rem Created By Salim Hasbaya On 29/9/2020
If ActiveSheet.Name <> "Salim" Then GoTo Bay_Bay
Application.ScreenUpdating = False
Dim Ro%, X%
Dim t%, k%, Roc%
Ro = Cells(Rows.Count, 2).End(3).Row
Roc = Cells(Rows.Count, 3).End(3).Row

With Range("D2:D" & Roc)
  .UnMerge
  .Clear
End With
 
 For X = 2 To Ro
    If Cells(X, 2).MergeCells = True Then
        t = Cells(X, 2).MergeArea.Rows.Count
        Cells(X, 4).Resize(t).Merge
        Cells(X, 4).Formula = _
         "=SUM(C" & X & ":C" & X + t - 1 & ")"
       X = X + t - 1
   Else
       Cells(X, 4).Formula = "=SUM(C" & X & ")"
   End If
 Next X
   
   With Range("D2:D" & Roc)
   .VerticalAlignment = 2
   .HorizontalAlignment = 3
   .Borders.LineStyle = 1
   .Font.Size = 18
   .Font.Bold = True
   End With
Bay_Bay:
 Application.ScreenUpdating = True
End Sub

Abd_naser_New.xlsm

[محمد عبد الناصر]

ماشاء الله استاذ سليم كود رائع جدااااااااااااااااااااا 
في ميزان حسناتك يارب