محي الدين ابو البشر

فنان.xlsm

عليكم السلام

وبالاذن

ربما 

Book111_1.xlsm

حل آخر

Sub test()
    Dim a
    Dim i&
    a = Sheets("DATA").Cells(1).CurrentRegion
    With CreateObject("scripting.dictionary")
    For i = 2 To UBound(a)
    If a(i, 3) = Sheets("RESULT").Cells(1, 5) Then
   If Not .exists(a(i, 1)) Then .Add a(i, 1), Array(a(i, 1), a(i, 2), a(i, 3))
   End If
    Next
    a = Application.Index(.items, 0, 0)
    End With
    With Sheets("RESULT").Cells(1).CurrentRegion.Offset(1)
.ClearContents
  .Resize(UBound(a), 3) = a
    End With
End Sub

السلام عليكم ممكن حل آخر

Sub test()
    Dim a
    Dim i&
    a = Sheets("Form Responses 1").Cells(4, 1).CurrentRegion
    With CreateObject("scripting.dictionary")
    For i = 2 To UBound(a)
    If a(i, 3) = Cells(2, 3) Then
   If Not .exists(a(i, 3) & a(i, 1)) Then
   .Add a(i, 3) & a(i, 1), Array(a(i, 3), a(i, 5), a(i, 6), a(i, 7), a(i, 8), a(i, 10), a(i, 15), a(i, 17), a(i, 19))
   End If: End If
    Next
    a = Application.Index(.items, 0, 0)
    End With
    With Sheets("Report").Cells(4, 2).Resize(UBound(a) - 1, 9)
        .ClearContents
        .Value = a
    End With
End Sub

Omar_1.Range("A" & i & ":R" & i).Delete
 or


Sheets("الملاك").Range("A" & i & ":R" & i).Delete

سلمك الله

الحمدلله

1-تجديد حركة السير.xlsm

المفروض أن تبدأ من جديد

عزيزي

أضغط بالزر اليميني للماوس على اسم الوقة التي تعمل علها ثم اضغط بالزر اليساري للماوس على (View Code) 

يفتح نافذة جديدة قم بلصق الكود فيها ببساطة

أغلق النافذة الجديدة ث اذهب إلى ورقة العمل التي تعمل عليها وفي العمود C  اكتب ()Today واضغط أنتر

سوف يتم الأمر

عليكم السلام

ضع هذا الكود في حدث الصفحة (Sheets Code)

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Range("C:C")) Is Nothing Then
        With Target: .Value = .Value: End With
    End If
End Sub

الحمد لله 

بارك الله

هكذا؟

Sub test()
    Dim dic1 As Object: Dim dic2 As Object
    Dim a, b, w, bb
    Dim i&
    a = Sheets("فودا").Cells(1).CurrentRegion
    b = Application.Transpose(Sheets("قاعدة العملاء").Cells(1).CurrentRegion.Columns(2))
    bb = Application.Transpose(Sheets("قاعدة العملاء").Cells(1).CurrentRegion.Columns(1))
    Set dic1 = CreateObject("scripting.dictionary")
    Set dic2 = CreateObject("scripting.dictionary")
    For i = 2 To UBound(a)
        If (IsNumeric(Application.Match(a(i, 3), b, 0))) Then
            If Not dic1.exists(a(i, 3)) Then
                dic1.Add a(i, 3), Array(a(i, 3), bb(Application.Match(a(i, 3), b, 0)), a(i, 7))
            Else
                w = dic1.Item(a(i, 3))
                w(2) = w(2) + a(i, 7)
                dic1.Item(a(i, 3)) = w
            End If
        Else
            If Not dic2.exists(a(i, 3)) Then
                dic2.Add a(i, 3), Array(a(i, 3), a(i, 2), a(i, 7))
            Else
                w = dic2.Item(a(i, 3))
                w(2) = w(2) + a(i, 7)
                dic2.Item(a(i, 3)) = w
            End If
        End If
    Next
    With Sheets("رحل")
      Union(Range(.Cells(3, 1), .Cells(3, 5).End(xlDown)), Range(.Cells(3, 8), .Cells(3, 11).End(xlDown))).ClearContents
        .Cells(3, 1).Resize(dic1.Count, 3) = Application.Index(dic1.items, 0, 0)
        .Cells(3, 8).Resize(dic2.Count, 3) = Application.Index(dic2.items, 0, 0)
    End With
End Sub

عليكم السلام

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

جرب هذا

Sub test()
    Dim dic1 As Object: Dim dic2 As Object
    Dim a, b, w, xx
    Dim i&
    a = Sheets("فودا").Cells(1).CurrentRegion
    b = Application.Transpose(Sheets("قاعدة العملاء").Cells(1).CurrentRegion.Columns(2))
    Set dic1 = CreateObject("scripting.dictionary")
    Set dic2 = CreateObject("scripting.dictionary")
    For i = 2 To UBound(a)
        If (IsNumeric(Application.Match(a(i, 3), b, 0))) Then
            If Not dic1.exists(a(i, 3)) Then
                dic1.Add a(i, 3), Array(a(i, 3), a(i, 2), a(i, 7))
            Else
                w = dic1.Item(a(i, 3))
                w(2) = w(2) + a(i, 7)
                dic1.Item(a(i, 3)) = w
            End If
        Else
            If Not dic2.exists(a(i, 3)) Then
                dic2.Add a(i, 3), Array(a(i, 3), a(i, 2), a(i, 7))
            Else
                w = dic2.Item(a(i, 3))
                w(2) = w(2) + a(i, 7)
                dic2.Item(a(i, 3)) = w
            End If
        End If
    Next
    With Sheets("رحل")
        Range(.Cells(3, 1), .Cells(3, 5).End(xlDown)).ClearContents
        Range(.Cells(3, 8), .Cells(3, 11).End(xlDown)).ClearContents
        .Cells(3, 1).Resize(dic1.Count, 3) = Application.Index(dic1.items, 0, 0)
        .Cells(3, 8).Resize(dic2.Count, 3) = Application.Index(dic2.items, 0, 0)
    End With
End Sub

خيار آخر قد يكون أسرع 

Sub test()
    Dim i As Integer
    Dim r As Range: Dim tr As Range
    With ActiveSheet
        For i = 1 To .UsedRange.Rows.Count + 2
            If Trim(.Cells(i, 3)) = "تعديل" Then
                If r Is Nothing Then
                    Set r = .Rows(i)
                Else
                    Set r = Union(r, .Rows(i))
                End If
            End If
        Next i
        r.Delete
    End With
End Sub

Sub test()
    Dim i As Integer
    With ActiveSheet
        For i = .UsedRange.Rows.Count + 2 To 1 Step -1
            If Trim(.Cells(i, 3)) = "تعديل" Then
                .Rows(i).Delete
            End If
        Next i
    End With
End Sub

بارك الله

ربما

Sub test()
Dim r&
With ActiveSheet
r = .Cells(Rows.Count, 4).End(xlUp).Row
 .Range("D4:I" & r).SpecialCells(4).Delete Shift:=xlUp
 .Range("$D$3:$D$" & r).RemoveDuplicates 1, 1
    End With
End Sub

شكراً لك

omar elhosseini

omar elhosseini

Count_Color_FormatConditions.xlsm

عليكم السلام أخي الكريم جرب هذا الكود عسى يكون المطلوب

Sub test()
    Dim z, col, cnt, x
    Dim i&, ii&
    Application.ScreenUpdating = False
    z = Array(15773696, 5287936, 65535, 255)
    col = Array("أزرق", "أخضر", "أصفر""أحمر")
    cnt = Array(0, 0, 0, 0)
    For ii = 10 To Cells(Rows.Count, 3).End(xlUp).Row
        cnt = Array(0, 0, 0, 0)
        For i = 7 To Cells(Columns.Count, 7).End(xlToRight).Column
            On Error Resume Next
            x = Application.Match(Cells(ii, i).DisplayFormat.Interior.Color, z, 0)
            cnt(x - 1) = cnt(x - 1) + 1
        Next
        Range("cy" & ii).Resize(, 4) = cnt
        Set cnt = Nothing
    Next
    Application.ScreenUpdating = True
End Sub

لوب

عليكم السلام

نفس معادلة السيد كريم نظيم لكن بتعديل حسب الملف الأخير

=IF(COUNTIFS($F$2:$F$1500,F2,$H$2:$H$1500,H2,$I$2:$I$1500,I2)>1,"تعارض","")

عليكم السلام

حسب ما فهمت

لمعرفة آخر تاريخ.xlsm

بارك الله