محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي Private Sub Worksheet_SelectionChange(ByVal Target As Range) StartColumn = 6 ' اول عمود LastColumn = 40 ' اخر عمود iRow = 20 ' رقم الصف Application.ScreenUpdating = False For i = StartColumn To LastColumn Application.ScreenUpdating = False If Range("b20").Value = "" Then Columns("F:H").EntireColumn.Hidden = False Exit Sub End If If Cells(iRow, i).Value > Range("b20").Value Then Cells(iRow, i).EntireColumn.Hidden = True Else Cells(iRow, i).EntireColumn.Hidden = False End If Next i End Sub كود اخفاء.xlsm

تفضل اخي ربما هدا ما تقصد Sub Test() Dim ws As Worksheet Dim rng As Range Dim cell As Range On Error GoTo Errorhandling Set ST = Sheet1 Set st2 = Sheet2 lr = ST.Range("H" & Rows.Count).End(xlUp).Row Sheet1.Range("B2:B" & lr).ClearContents st2.Visible = True Set rng = Range("H2:H" & lr) Application.DisplayAlerts = False Application.ScreenUpdating = False For Each ws In Worksheets If ws.Name <> ("Vehicle") And ws.Name <> ("Data") And ws.Name <> ("Sample") Then ws.Delete End If Next For Each cell In rng If cell <> "" Then Worksheets("Sample").Copy After:=Worksheets(Worksheets.Count) ActiveSheet.Name = cell Range("i19").Value = ActiveSheet.Name End If Next cell Errorhandling: Sheet1.Activate Sheet1.Range("b2").Select For Each ws In ActiveWorkbook.Worksheets If ws.Name <> ("Vehicle") And ws.Name <> ("Data") And ws.Name <> ("Sample") Then ActiveCell.Hyperlinks.Add Anchor:=ActiveCell, Address:="", SubAddress:="" & ws.Name & "!A1" & "", ScreenTip:="", TextToDisplay:=ws.Name ActiveCell.Offset(1, 0).Select Application.DisplayAlerts = True Application.ScreenUpdating = True End If Next ws st2.Visible = False End Sub

السلام عليكم ورحمة الله تعالى وبركاته ملاحظة :بعد ادن الاخوة الكرام بعد معاينة الكود الموجود في اليوزرفورم السائل ربما يقصد انشاء اوراق عمل جديدة طبق الاصل للورقة المخفية (sample) بشرط الاسماء الموجودة في عمود H شيت ( Vehicle ) واعادة تسميتها بنفس القيمة

لا لم انسى لاكن هدا ما فهمت من رسالتك الاخيرة على العموم تم اظافة المطلوب في المرفق التالي sella_V2.xlsm

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