نجوم المشاركات

الله يبارك فيك وأكثر الله من أمثالك

لحذف الصفوف التي استلمت الدفعتين الأولى والثانية والإبقاء على الذين استلموا دفعة واحدة يمكنك القيام بذلك يدوياً بدون الحاجة إلى استخدام معادلة أو كود عن طريق اتباع الخطوات التالية: انقر على فلتر العمود "تاريخ الدفعة الثانية" (العمود C) قم بإلغاء تحديد القيم الفارغة بحيث تعرض الصفوف التي تحتوي على تاريخ في العمود "تاريخ الدفعة الثانية" بعد تطبيق الفلتر، حدد جميع الصفوف الظاهرة (هذه هي الصفوف التي استلمت الدفعتين) / اضغط بزر الماوس الأيمن على التحديد، واختر "حذف صف" (Delete Row) بعد حذف الصفوف، قم بإعادة تعيين الفلتر ليعرض جميع البيانات مرة أخرى بهذا الشكل ستحتفظ بالصفوف التي استلمت دفعة واحدة فقط

وعليكم السلام ورحمة الله تعالى وبركاته 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