محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك استخدام المعادلة التالية =IF(LEFT(TRIM(B2);1)="1";"س";"ج") ملف.xlsx

تفضل جرب اخي سعد هذا حل بواسطة اليوزرفورم sella_V1.xlsm

معيارين الصف والسنة فقط مع ترحيل البيانات إلى ورقة 2 صح؟

تمام ممكن تذكر لي المعايير التي تريد الفلترة بها. على حسب ما فهمت . الرقم القومي والصف والسنة والتحويل في حالة الرغبة بإضافة عنصر آخر يمكنك ذكره ملاحظة: ليس شرطا أن تقوم بفلترة البيانات على جميع المعايير. يمكنك اختيار ما تشاء مع امكانية الاشتغال على قوائم ديناميكية لتسهيل عملية الفلترة

في وجهة نظري بما أنك تريد الإختيار من القوائم.الافضل أنك تقوم بفلترة البيانات من خلال الشيت نفسه أو يوزرفورم صغير بالمعايير التي تريد وبالطريقة التي تحب سواءا فلترة الجدول نفسه أو على ليست بوكس ومن ثم ترحيلها مباشرة إلى شيت 2 !!! اذا وافقت على الفكرة يمكننا فعلها باذن الله

1)لم توضخ المطلوب جيدا هل هناك أسماء محددة تريد تغييرها. 2) هل التنفيذ على نطاق معين أو على الشيت بالكل Sub Replace() Dim sheet As Worksheet Dim Réf As Variant Dim val As String Dim y As Long Réf = Array("علي", "محمد", "احمد", "ضياء") val = "موظف" For y = LBound(Réf) To UBound(Réf) For Each sheet In ActiveWorkbook.Worksheets sheet.Columns("A:A").Replace What:=Réf(y), Replacement:=val, _ LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _ SearchFormat:=False, ReplaceFormat:=False Next sheet Next y End Sub لتنفيد الامر على جميع خلايا ورقة العمل يمكنك استبدال هذا الجزء من الكود sheet.Cells.Replace What:=Réf(y), Replacement:=val, _ LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _ SearchFormat:=False, ReplaceFormat:=False Next sheet Next y test.xlsm

اخي حاول التأكد من نطاق الخلايا أو رفع عينة شبيهة للملف الخاص بك للوقوف وراء سبب عدم تنفيذ الكود على جميع الخلايا

Sub test2() lr = [b10000].End(xlUp).Row Range("B2:b" & lr).CurrentRegion.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlYes End Sub صراحة لست متاكدا من المطلوب لاكن ما فهمت هو ازالة الصفوف عند التحقق من التكرار في جميع خلايا النطاق من العمود b الى h لاكن جملة الفاتورة المحددة تتضمن ربما تفسير اخر .هل تقصد تحديد رقم الفاتورة في خلية معينة مثلا او .....

السلام عليكم ورحمة الله تعالى وبركاته اليك اخي حل اخر بالاكواد Sub test() Dim ws As Worksheet Dim MOSS As Range Dim lr As Long Set ws = Worksheets("ورقة1") Application.ScreenUpdating = False lr = Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row Set MOSS = ws.Range("A1:O" & lr) For Each ColorCell In MOSS If ColorCell <> "" Then ColorCell.Interior.Color = RGB(220, 230, 241) Else ColorCell.Interior.ColorIndex = xlNone End If Next End Sub مسودة تحذف.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي جرب Sub Supprimer_la_ligne_en_double_B() Dim Rng As Range Dim X As Long Set Rng = Range("B2", Range("B" & Rows.Count).End(xlUp)) X = Rng.Rows.Count For X = X To 1 Step -1 With Rng.Cells(X, 1) If WorksheetFunction.CountIf(Rng, .Value) > 1 Then .EntireRow.Delete End If End With Next X End Sub حذف الفواتير المكررة.xlsm

السلام عليكم ورحمة الله تعالى وبركاته. تفضل اخي ربما تقصد ترحيل البيانات بشرط الإسم الموجود في الخلية M3 اليك حل آخر بالمعادلات . INDIRET COSTS 2023_V1.xlsx

تفضل جرب اخي اسم المستخدم: admin كلمة المرور : 12345 Private Sub CommandButton1_Click() Dim sh As Worksheet Set sh = Sheet1 Dim lr As Long lr = sh.Range("A" & Rows.Count).End(xlUp).Row '''''''''''''''Validation''''''''' With sh .Cells(lr + 1, "A").Value = Me.TextBox2.Text .Cells(lr + 1, "B").Value = Me.TextBox3.Text .Cells(lr + 1, "C").Value = Me.TextBox4.Text .Cells(lr + 1, "D").Value = Me.TextBox5.Text .Cells(lr + 1, "E").Value = Me.TextBox6.Text .Cells(lr + 1, "F").Value = Me.TextBox7.Text .Cells(lr + 1, "G").Value = Me.TextBox8.Text .Cells(lr + 1, "H").Value = Me.TextBox9.Text .Cells(lr + 1, "i").Value = Me.TextBox10.Text .Cells(lr + 1, "j").Value = Me.TextBox11.Text .Cells(lr + 1, "k").Value = Me.TextBox12.Text End With For i = 1 To 12 Controls("textbox" & i + 1).Value = "" On Error Resume Next Next i ListBox1.ColumnCount = 11 ListBox1.RowSource = "A1:K100000" MsgBox "تمت اضافة البيانات بنجاح" End Sub قاعدة بيانات1.xlsm

نعم اخي يمكنك دالك باضافة بسيطة للكود ليتم تنفيده فقط عند التغيير في عمود C Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, Range("C:C")) Is Nothing Then Set f = Sheet2 's("المخزن") Set m = Sheet1 's("البيانات") Application.ScreenUpdating = False Set MonDico = CreateObject("Scripting.Dictionary") For Each a In f.Range("C3", [C65000].End(xlUp)) If a <> "" Then MonDico(a.Value) = "" Next a With m.Range("C3:C65000") .ClearContents .Resize(MonDico.Count) = Application.Transpose(MonDico.keys) End With End If End Sub

السلام عليكم ورحمة الله تعالى وبركاته بعد ادن الاخوة الكرام اليك حل اخر على حسب ما فهمت من طلبك وهو نسخ الصفوف بشرط عدم وجود قيمة صفرية في جميع الخلايا من العمود F الى N Sub CopyData() Dim x, i As Long, j As Long, MH As Long, n As Long Dim st As Worksheet, WS As Worksheet, s As String Application.ScreenUpdating = False Set st = Sheets("Budget 2023") MH = st.Range("D" & Rows.Count).End(xlUp).Row x = st.Range("D1:N" & MH) ReDim Preserve x(1 To UBound(x), 1 To UBound(x, 2) + 1) For i = 1 To UBound(x) For j = 3 To UBound(x, 2) - 1: x(i, UBound(x, 2)) = x(i, UBound(x, 2)) & x(i, j): Next j Next i Set WS = Sheets("résultat") WS.Range("A:K").ClearContents For i = 1 To UBound(x) If x(i, UBound(x, 2)) <> 0 Then n = n + 1 For j = 1 To UBound(x, 2): x(n, j) = x(i, j): Next End If Next With WS.Range("A1").Resize(n, UBound(x, 2) - 1) .Value = x .HorizontalAlignment = xlCenter '.BorMHs.LineStyle = xlContinuous End With End Sub Budget 2023_v1.xlsb

ضعه بحدث شيت المخزن بهذه الطريقة اخي ' Private Sub Worksheet_SelectionChange(ByVal Target As Range) Set f = Sheet2 Set m = Sheet1 Application.ScreenUpdating = False f.Activate Set MonDico = CreateObject("Scripting.Dictionary") For Each a In f.Range("C3", [C65000].End(xlUp)) If a <> "" Then MonDico(a.Value) = "" Next a With m.Range("C3:C65000") .ClearContents .Resize(MonDico.Count) = Application.Transpose(MonDico.keys) End With End Sub V3_تصفية بيانات المخزن (1).xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي Sub SansDoublons() Set f = Sheets("المخزن") Set M = Sheets("البيانات") Application.ScreenUpdating = False Set réf = CreateObject("Scripting.Dictionary") A = Range(f.[C3], f.[C65000].End(xlUp)).Value For Each c In A réf(c) = "" Next c Set dest = M.Range("C3") dest.Resize(réf.Count, 1) = Application.Transpose(réf.keys) ' ترتيب ابجدي dest.Resize(réf.Count, 1).Sort Key1:=dest, Order1:=xlAscending Set réf = Nothing End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 'في حالة الرغبة بوضع الكود في حدث الشيت Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, Range("C:C")) Is Nothing Then Set f = Sheets("المخزن") Set M = Sheets("البيانات") Set réf = CreateObject("Scripting.Dictionary") A = Range(f.[C3], f.[C65000].End(xlUp)).Value For Each c In A réf(c) = "" Next c Set dest = M.Range("C3") dest.Resize(réf.Count, 1) = Application.Transpose(réf.keys) dest.Resize(réf.Count, 1).Sort Key1:=dest, Order1:=xlAscending Set réf = Nothing End If End Sub V1_تصفية بيانات المخزن .xlsm

السلام عليكم ورحمة الله تعالى وبركاته نظرا لحجم اليوزرفورم الكبير وصعوبة التعامل معه قد تم الاشتغال على النسخة الاولى للفورم . واضافة المطلوب يمكنك تكييف الامور بما يناسبك طلب وتعديل يوزيرفورم 4.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته اليك حل اخر =IF(A5<>"";DATE(YEAR(A5);MONTH(A5);DAY(A5)+1);"") '''''''''''''''''''''''''''''''''' =IF(A5<>"";DATE(YEAR(A5)+1;MONTH(A5);DAY(A5)-1);"") تاريخ.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته arr = SH.Range("A5:H" & SH.Cells(Rows.Count, 1).End(xlUp).Row).Value2

=IFERROR(VLOOKUP(@$A$2:$A$6,Sheet2!$A$1:$B$6,2,0),"")

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي اليك برامج هدية لك ولكل اعضاء وزوار منتدى اوفيسنا . ملف تم تعديله بطريقة دينامكية تمكنك من دمج اكثر من 100 ملف في مجلدات مختلفة في ملف واحد . رابط لشرح طريقة الاستخدام بالتوفيق............ Sh_2023.zip

لاكن اخي الورقة 1 لا تتضمن أسماء الموظفين .

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي للبحث برؤوس الاعمدة وجلب بيانات العمود يمكنك استخدام المعادلة التالية مع سحب المعادلة للاسفل على حسب قدر البيانات عندك في ورقة 1 =IFERROR(INDEX('الورقة 1'!A6:AC6;XMATCH($P$3;'الورقة 1'!$A$4:$AC$4;0));"") اسماء المحافظات والمدن.en.ar (2).xlsx

اخي طلبك غير واضح.المشكلة تكمن في طريقة طرحك للموضوع. قم على الأقل بوضع عينة للنتائج المتوقعة لنستطيع مساعدتك .

اخي هل هناك ملف اخر غير الدي قمت بارفاقه في المشاركة تريد تنفيد الامر عليه بعد اضافة الكود قم بحفظ الملف بصيغة الماكرو