جمع ودمج على شرط التاريخ

[عمر الجزاوى]

السلام عليكم ورحمة الله وبركاته بعد أساتذة المنتدى نريد كود يعمل الاتى في عمود التاريخ نكتب التاريخ ونضع امام كل تاريخ مبلغ التوريد نريد عمل كود يرى التاوريخ المتشابها وجمع مبالغها ثم يدمجها كما هو واضح في الشيت هنضرب مثال تاريخ 1 / 9 / 2024 مكرر 5 مرات نجمع كل المبالغ الموجوده فى تاريخ 1 / 9  ثم يدمجها وجزاكم الله خير

جمع ودمج بشرط التاريخ.xlsm

[محمد هشام.]

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

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim OnRng As Range, arr As Range, dict As Object, n As Long, f As String
    Dim lastRow As Long, SumCol As Long, a As Long

    Dim WS As Worksheet: Set WS = Me

    lastRow = WS.Columns("C:E").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    
    If Not Intersect(Target, WS.Range("C6:D" & lastRow)) Is Nothing Then
        With Application
            .DisplayAlerts = False
            .ScreenUpdating = False
            
            If lastRow > 6 Then
                With WS.Range("E6:E" & lastRow)
                    .UnMerge
                    .ClearContents
                End With
            End If
            
            Set dict = CreateObject("Scripting.Dictionary")
            SumCol = WS.Cells(WS.Rows.Count, 3).End(xlUp).Row
            Set OnRng = WS.Range("C6:C" & SumCol)
            Set arr = WS.Range("D6:D" & SumCol)

            For n = 1 To OnRng.Rows.Count
                f = Trim(OnRng(n).Value)
                If Len(f) > 0 And IsNumeric(arr(n).Value) Then
                    If dict.Exists(f) Then
                        dict(f) = dict(f) + arr(n).Value
                    Else
                        dict.Add f, arr(n).Value
                    End If
                End If
                
                If Len(Trim(arr(n).Value)) = 0 Then
                    WS.Cells(n + 5, 5).Value = ""
                End If
            Next n

            n = 6
            Do While n <= SumCol
                f = Trim(WS.Cells(n, 3).Value)
                If Len(f) > 0 Then
                    If dict.Exists(f) Then
                        WS.Cells(n, 5).Value = dict(f)
                        a = n
                        Do While n <= SumCol And Trim(WS.Cells(n, 3).Value) = f
                            n = n + 1
                        Loop
                        If n - a > 1 Then
                            WS.Range(WS.Cells(a, 5), WS.Cells(n - 1, 5)).Merge
                        End If
                    Else
                        n = n + 1
                    End If
                Else
                    n = n + 1
                End If
            Loop
            
            Set dict = Nothing
            .ScreenUpdating = True
            .DisplayAlerts = True
        End With
    End If
End Sub

 

جمع ودمج بشرط التاريخ.xlsm

[عمر الجزاوى]

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