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

فنان.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

بارك الله