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

وعليكم السلام ربما Sub test() Dim a Dim i& a = Range(Cells(2, 6), Cells(2, 6).End(xlDown)).Cells With CreateObject("scripting.dictionary") For i = 1 To UBound(a) If Not .exists(a(i, 1)) Then .Add a(i, 1), a(i, 1) Next For i = 2 To Cells(Rows.Count, 9).End(xlUp).Row If Not .exists((Cells(i, 9).Value)) Then Cells(i, 9).Interior.Color = vbRed End If Next End With End Sub أو Sub tes2() Dim a Dim i& With CreateObject("scripting.dictionary") For i = 1 To Cells(Rows.Count, 6).End(xlUp).Row If Not .exists(Cells(i, 6).Value) Then .Add Cells(i, 6).Value, "" Next For i = 2 To Cells(Rows.Count, 9).End(xlUp).Row If Not .exists((Cells(i, 9).Value)) Then Cells(i, 9).Interior.Color = vbYellow End If Next End With End Sub مع المحافظة على لون الخلية عند تغيير القيمة

وعليكم السلام والرحمة ربما Sub test() Dim a, w, x, k Dim i&, ii& a = Cells(1).CurrentRegion With CreateObject("scripting.dictionary") For i = 5 To UBound(a) If Not .exists(a(i, 9)) Then .Add a(i, 9), Array(a(i, 9), a(i, 2), a(i, 3) & "\" & a(i, 4), "SP" & a(i, 5) & " PORT " & Format(a(i, 6), "0#"), "TB Number " & Format(a(i, 7), "0#")) Else w = .Item(a(i, 9)) x = Split(w(3), "-") If UBound(x) > 0 Then w(3) = x(0) & "- " & Format(a(i, 6), "0#") .Item(a(i, 9)) = w Else x(UBound(x)) = x(UBound(x)) & " -" & Format(a(i, 6), "0#") w(3) = Join(x) .Item(a(i, 9)) = w End If: End If Next For Each k In .keys Cells(5 + ii, 13).Resize(5) = Application.Transpose(.Item(k)) ii = ii + 6 Next End With End Sub

السلام عليكم وهذا خيار آخر Sub test2() Dim a, b Dim i&, ii& a = Cells(7, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row, 2) ReDim b(0 To UBound(a), 1 To 1) For i = 1 To UBound(a) If a(i, 1) & a(i, 2) <> "" And a(i, 1) <> 0 And a(i, 2) <> "" And a(i, 1) <> 0 And _ WorksheetFunction.IsNumber((a(i, 1))) Then b(ii, 1) = i: ii = ii + 1 Next Cells(7, 10).Resize(ii, 2) = Application.Index(a, b, Array(1, 2)) End Sub

عليكم السلام جرب المعادلة في الخلية B2 , اسحب نزولا ويسارا عسى يكون المطلوب =INDEX('1'!$A$1:$AN$74,MATCH($A2,'1'!$A$1:$A$74,0),MATCH($A$1:$AN$1,'1'!$A$1:$AN$1,0)) أو =INDEX('1'!$A$1:$AN$74;MATCH($A2;'1'!$A$1:$A$74;0);MATCH($A$1:$AN$1;'1'!$A$1:$AN$1;0)) حسب الإعدادات لديك تجربة (2).xlsx

وعليكم السلام خيار آخر Sub Test() Dim a Dim i& Application.ScreenUpdating = False a = Cells(7, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row, 2) With CreateObject("scripting.dictionary") For i = 1 To UBound(a) If a(i, 1) & a(i, 2) <> "" And a(i, 1) <> 0 And a(i, 2) <> "" And a(i, 1) <> "" And WorksheetFunction.IsNumber((a(i, 1))) Then If Not .exists(a(i, 1) & "|" & a(i, 2)) Then .Add a(i, 1) & "|" & a(i, 2), "" End If Next Cells(7, 5).Resize(.Count) = Application.Transpose(.keys) Application.DisplayAlerts = False Cells(7, 5).Resize(.Count).TextToColumns Destination:=Range("E7"), OtherChar:="|", FieldInfo:=Array(2, 1) End With Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub

عليكم السلام تفضل أخي الكريم يجب مراعاة أن يكون الملفين مفتوحين شيت رقم 1.xlsm

هكذا؟ Sub Triage() With ActiveWorkbook.Worksheets("BLF").ListObjects("Tableau2") .Sort.SortFields.Clear .Sort.SortFields.Add Key:=Range("Tableau2[Date Echeance]") .Sort.SortFields.Add2 Key:=Range("Tableau2[Client]") With .Sort .Header = xlYes .Apply End With End With End Sub

بارك الله

عليكم السلام جرب Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("f:f")) Is Nothing Then Range("Tableau2[[#Headers],[#Data]]").Sort Key1:=Range("f1"), Order1:=xlAscending, Header:=xlYes End If End Sub

بالاذن ربما يكون المطلوب test.xlsm

🙏

If x > 45 And cells(I,"H")= "" Then

بارك الله ولك وللقائمين على المنتدى جميعا مثلما دعوت

وعليكم السلام من Format cells - Custom اكتب في حقل Type: yyyymmdd

وعليكم السلام وارحمة استبدل 1 بـ 2 B1.xlsm

رحمه الله و أسكنه فسيح جناته

xlsاوفسينا.xls

السلام عليكم عذراً أخي الكريم على التأخير في الرد استبدل test2 بـ الكود Sub test2() Dim a, y Dim i&, c&, x& Application.ScreenUpdating = False Sheets("جميلة").Columns(1).ClearContents a = Sheets("sheet1").Cells(5, 1).Resize(Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row - 4) For i = 1 To UBound(a) If a(i, 1) <> "" Then y = Split(a(i, 1)) If IsNumeric(Application.Match("جميلة", Split(a(i, 1)), 0)) Then x = Application.Match("جميلة", Split(a(i, 1)), 0) If UBound(y) > 21 Then y = Application.Transpose(Application.Index(y, Evaluate("row(" & x - 10 & ":" & x + 10 & ")"))) Sheets("جميلة").Cells(c + 1, 1) = Join(y) Else Sheets("جميلة").Cells(c + 1, 1) = a(i, 1) End If c = c + 1 End If: End If Next Sheets("جميلة").Activate Application.ScreenUpdating = True End Sub

xlsاوفسينا.xls

لا أدري ما المشكلة عندك على كل اتبع ما هو هو مكتوب في المرفق اوفسينا.xlsm

تفضل اوفسينا.xlsm

حل آخر Sub test2() Dim a Dim i&, c& a = Sheets("sheet1").Cells(5, 1).Resize(Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row - 4) For i = 1 To UBound(a) If a(i, 1) <> "" Then If IsNumeric(Application.Match("جميلة", Split(a(i, 1)), 0)) Then Sheets("جميلة").Cells(c + 1, 1) = a(i, 1) c = c + 1 End If: End If Next End Sub

عليكم السلام ربما Sub test() Dim a Dim i&, c& a = Sheets("sheet1").Cells(5, 1).CurrentRegion.Columns(1) With CreateObject("VBScript.RegExp") .Global = True .Pattern = "جميلة" For i = 1 To UBound(a) If .test(a(i, 1)) Then Sheets("جميلة").Cells(c + 1, 1) = a(i, 1) c = c + 1 End If Next End With End Sub

بارك الله

عليكم السلام عسى غياب يومية.xlsm