محمد هشام.

او جرب هدا ربما هدا ما تقصده Private Sub CommandButton1_Click() Dim WS As Worksheet, NewWb As Workbook Dim Path As Variant Set WS = Worksheets("Sheet18") If WS.[E2] = 0 Then: Exit Sub 'Path = "D:\test\" في حالة كان المسار ثابت يمكنك تعديل السطر التالي بما يناسبك ' ' اختيار مسار الحفظ Path = Application.GetSaveAsFilename(InitialFileName:=WS.[E2], _ fileFilter:="Excel Files (*.xlsx), *.xlsx", Title:="الرجاء اختيار مكان الحفظ") If Path <> False Then Application.DisplayAlerts = False Application.ScreenUpdating = Fals WS.Copy Set NewWb = ActiveWorkbook With NewWb.Sheets(1).UsedRange .Value = .Value End With NewWb.SaveAs Path, FileFormat:=51 '**************************************************************** ' هدا للمسار الثايت ' NewWb.SaveAs Filename:=Path & WS.[E2] & ".xlsx", FileFormat:=51 '********************************************************************* NewWb.Close Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox "Saved successfully" Unload Me End If End Sub SAV 18 v2.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Private Sub CommandButton1_Click() Dim newWb As Workbook Dim WS As Worksheet: Set WS = Sheets("Sheet18") Path = ThisWorkbook.Path & "\" 'OR =====>>'"D:\test\" If WS.[E2] = 0 Then: Exit Sub Application.ScreenUpdating = False Application.DisplayAlerts = False WS.Copy Set newWb = ActiveWorkbook newWb.SaveAs Filename:=Path & WS.[E2] & ".xlsx", FileFormat:=51 newWb.Close Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox "Saved successfully" End Sub SAV 18.xlsb

تفضل اخي جرب هدا بعد إلغاء ارتباط Combobox (PREPARATEURS) من اعدادات اليوزرفورم كما في الملف المرفق Private Sub UserForm_Initialize() Set f = Sheets("PREPARATEUR ") Set d = CreateObject("Scripting.Dictionary") a = f.Range("A2:A" & f.[A65000].End(xlUp).Row) For i = LBound(a) To UBound(a) If a(i, 1) <> "" Then d(a(i, 1)) = "" Next i Me.PREPARATEURS.List = d.keys Me.DATES.Value = Date Me.HEURS.Value = Format(Now, "hh:mm:ss") End Sub '***************************** Private Sub AJOUTER_Click() Dim tbl As ListObject Dim arr, lr As Long, lige As Range, cmb() Set tbl = Range("LISTE_DE_BL").ListObject arr = Array(DATES.Value, HEURS.Value, _ Me.BLS.Value, Me.PREPARATEURS.Value) Set lige = tbl.ListColumns(1).Range.Find(What:="*", _ SearchOrder:=xlByRows, SearchDirection:=xlPrevious) lige.Offset(1).Resize(1, 4).Value = arr Me.BLS = "": Me.PREPARATEURS = "" ThisWorkbook.Save UserForm_Initialize End Sub احتمالات واردة If Me.BLS.Value = "" Then: MsgBox "Please Enter N°BL", vbCritical: BLS.SetFocus: Exit Sub If Me.PREPARATEURS.Value = "" Then _ MsgBox "Please Enter a Name PREPARATEURS", vbCritical: PREPARATEURS.SetFocus: Exit Sub 'حقل اليوم و الوقت غير قابلة للتغيير Me.DATES.Locked = True Me.HEURS.Locked = True VBA V2.xlsm

ارفق ملفك اخي الكريم

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

وعليكم السلام ورحمة الله تعالى وبركاته بعد إذن صاحب الملف أستادنا الكبير @ضاحي الغريب وتجنبا للتعديل على الأكواد الخاصة به رغم أنني متأكد أنه تم التلاعب بها مسبقا قمت بحدف جميع الأكواد الموجودة داخل اليوزرفورم وإعادة ترتيب تسلسل عناصر TEXTBOX بما يتناسب مع شكل وتصمييم الملف وإنشاء أكواد جديدة بطريقتي الخاصة و إظافة بعض اللمسات مع الاحتفاظ على نفس فكرة إشتغال اليوزرفورم تفضل اخي @ehabaf2 أتمنى أن يلبي طلبك Dim Btn(1 To 5) As New ClasseBoutons Dim ExitLoop As Boolean Const dict As Integer = 61 Private Const b As Long = 1 Private Const SearchColumn As String = "A" Public Property Get WS() As Worksheet: Set WS = Sheets("DATA"): End Property Private Sub UserForm_Initialize() For i = 1 To 5 Set Btn(i).GrBoutons = Me("commandbutton" & i) Next i Dim temp() Col = WS.Evaluate("SUM(0+(A5:A" & _ WS.Cells(WS.Rows.Count, "A").End(xlUp).Row & "<>""""))") Set tbl = CreateObject("Scripting.Dictionary") For Each c In WS.Range("A4:A" & WS.[a65000].End(xlUp).Row) If c.Value <> "" Then tbl.Item(c.Value) = c.Value Next c temp = tbl.items Tri temp, LBound(temp), UBound(temp) Me.ComboBox1.List = temp Me.limite.Value = Col End Sub '**************************** Private Sub ComboBox1_Change() ' بجث وجلب البيانات Dim fnd As Range, i As Long, sequence As String sequence = Me.ComboBox1 If Len(sequence) = 0 Then Exit Sub If IsNumeric(sequence) Then Set fnd = WS.Columns(SearchColumn).Find(sequence, , , xlWhole) If fnd Is Nothing Then MsgBox "! لم يتم العثور على رقم التسلسل " & " : " & _ sequence & " " & "في قاعدة البيانات", 16, "تم ايقاف تنفيد الكود" Me.ComboBox1 = "" Exit Sub End If For i = 1 To dict Me.Controls("TextBox" & i).Value = fnd.Offset(, i - b).Value Next i End If End Sub '************************************ Private Sub CommandButton1_Click() ' ترحيل Dim i As Long, src As Range Set src = WS.Range("A" & WS.Rows.Count).End(xlUp) If Me.TextBox3 = "" Then: MsgBox "يرجى اظافة " & ":" & Me.Label2.Caption, 16: Exit Sub r = MsgBox("ترحيـل البيانات؟", vbYesNo, "تأكيـــد"): If r <> vbYes Then Exit Sub For i = 1 To dict Application.ScreenUpdating = False src.Offset(b, i - b).Value = Me.Controls("TextBox" & i).Value With WS.Range("A5:A" & WS.Cells(WS.Rows.Count, "C").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-4") End With Me.Controls("TextBox" & i).Value = Null: Me.ComboBox1 = Empty Next i UserForm_Initialize Application.ScreenUpdating = True End Sub '******************************** Private Sub CommandButton3_Click() 'حدف Dim sequence As String sequence = Me.ComboBox1 If Len(sequence) = 0 Then Exit Sub r = MsgBox("حدف البيانات؟", vbYesNo, "تأكيـــد"): If r <> vbYes Then Exit Sub Application.ScreenUpdating = False With WS For i = .[a65000].End(xlUp).Row To 5 Step -1 If .Cells(i, (SearchColumn)) = sequence Then .Cells(i, 1).Resize(1, 61).Delete Shift:=xlUp Next i With Range("A5:A" & .Cells(.Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-4") End With End With Clear_TextBox Application.ScreenUpdating = True UserForm_Initialize End Sub '******************************** Private Sub CommandButton2_Click() ' تعديل Dim fnd As Range, sequence As String Dim i As Integer sequence = Me.ComboBox1 If Len(sequence) = 0 Then Exit Sub r = MsgBox("تعديل البيانات؟", vbYesNo, "تأكيـــد"): If r <> vbYes Then Exit Sub Application.ScreenUpdating = False Set fnd = WS.Columns(SearchColumn).Find(sequence, , , xlWhole) For i = 1 To dict WS.Cells(fnd.Row, i) = Controls("textbox" & i).Value Next i Clear_TextBox Application.ScreenUpdating = True UserForm_Initialize End Sub ملاحظة : أكواد البحث و التعديل والحدف يتم تنفيدها بشرط عمود التسلسل / الترحيل بشرط وجود قيمة في Textbox رقم الموظف واي اظافة او تعديل لا تتردد في دكره سنكون سعداء دائما بحصولك على النتائج المتوقعة لقد تركت لك إمكانية وضع توقيعك على اليوزرفورم 😃😃😃 بالتوفيق............ ملف ترحيل بالفورم V2.xlsm

اخي @ahmedabuzena تم تعديل الكود و اظافة عمود فارغ بين الجداول في المشاركة السابقة

جرب هدا Sub Print_Tbl() Dim lr As Long Set WS = Sheets("ELRASHIDY") Application.ScreenUpdating = False With WS .ResetAllPageBreaks lr = WS.Columns("B:X").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Application.PrintCommunication = False With WS.PageSetup .PrintArea = WS.Range("B2:X" & lr).Address .FitToPagesWide = 1 .FitToPagesTall = 1 End With End With Application.PrintCommunication = True Application.ScreenUpdating = True ActiveWindow.SelectedSheets.PrintPreview 'WS.PrintOut Copies:=1 End Sub اخي لقد حاولت حدف الاعمدة الغير مستخدمة مما سيجبرني على تعديل الكود السابق بما يناسب التصمييم الجديد Sub my_date() Dim xDate As String, i As Long Set sh = Sheets("ELRASHIDY") Do xDate = InputBox("insert date format month/year ", "insert month date", "MM/YYYY") If StrPtr(xDate) = 0 Then Exit Sub If xDate = "MM/YYYY" Then MsgBox "يرجى ٌإدخال التاريخ", 48 Loop While xDate = "MM/YYYY" If Not IsDate(xDate) Or Not (xDate) Like "##/####" Then _ MsgBox "يرجى التحقق من التاريخ", 16: Exit Sub Application.ScreenUpdating = False With sh .Range("A6:B36,I6:J36").ClearContents cnt = DateSerial(Year(xDate), Month(xDate), 1) arr = Array("A6", "I6", "G4", "O4") tmp = DateSerial(Year(xDate), _ Month(xDate) + 1, 1) - cnt For i = LBound(arr) To UBound(arr) .Range(arr(i)).Value = cnt Next i [A6].AutoFill Destination:=[A6].Resize(tmp), Type:=xlFillDays [I6].AutoFill Destination:=[I6].Resize(tmp), Type:=xlFillDays For i = 6 To sh.Cells(Rows.Count, "A").End(xlUp).Row ColDates = Range("A" & i).Value DayName = Format(ColDates, "dddd") With Union(sh.Range("B" & i), sh.Range("J" & i)) .Value = DayName End With Next i End With Application.ScreenUpdating = True End Sub Sub PrintTb2() Dim lr As Long Set WS = Sheets("ELRASHIDY") With WS .ResetAllPageBreaks lr = .Cells(.Rows.Count, "a").End(xlUp).Row Application.PrintCommunication = False With WS.PageSetup .PrintArea = WS.Range("A2:O" & lr).Address .FitToPagesWide = 1 .FitToPagesTall = 1 End With Application.PrintCommunication = True WS.PrintPreview 'WS.PrintOut Copies:=1 End With End Sub SHADY TIME TABLE 1_V4.xls

وعليكم السلام ورحمة الله تعالى وبركاته رغم انه في وجهة نظري ان الاقتراح المقدم من اخينا @AbuuAhmed افضل واسهل وينفد المطلوب دون الحاجة لاستخدام صندوق الادخال في حالة كانت لك رغبة لاستخدام نفس الطريقة يمكنك تجربة هدا Sub my_date() Dim xDate As String, i As Long Set sh = Sheets("ELRASHIDY") xDate = InputBox("insert date format month/year ", "insert month date", "MM/YYYY") If StrPtr(xDate) = 0 Then Exit Sub If Not IsDate(xDate) Or Not (xDate) Like "##/####" Then _ MsgBox "يرجى التحقق من تاريخ الادخال", vbExclamation: Exit Sub Application.ScreenUpdating = False With sh .Range("B6:C36,N6:O36").ClearContents tmp = DateSerial(Year(xDate), _ Month(xDate) + 1, 1) - DateSerial(Year(xDate), Month(xDate), 1) Range("B6,N6,I4").Value = DateSerial(Year(xDate), Month(xDate), 1) [B6].AutoFill Destination:=[B6].Resize(tmp), Type:=xlFillDays [N6].AutoFill Destination:=[N6].Resize(tmp), Type:=xlFillDays For i = 6 To sh.Cells(Rows.Count, "b").End(xlUp).row ColDates = Range("b" & i).Value DayName = Format(ColDates, "dddd") With Union(sh.Range("C" & i), sh.Range("O" & i)) .Value = DayName End With Next i End With Application.ScreenUpdating = True End Sub SHADY TIME TABLE 1_V2.xls

وعليكم السلام ورحمة الله تعالى وبركاته إذا كنت قد إستوعبت طلبك بشكل صحيح هذا سيوفي بالغرض Sub Trhel() Dim tmp As Range, C As Range Dim rng As Range: Set rng = [B1:B3] Check = Len([B1]) Share = [H1].Value If WorksheetFunction.CountA(rng) < 3 Or Share = 0 Then Exit Sub Set tmp = [C6:N6].Find([B2]) 'Or <<========'Set tmp = Rows(6).Find([B2]) For Each j In Range("b7:b" & Cells(Rows.Count, "b").End(xlUp).Row) A = j.Row: B = tmp.Column: Set C = Cells(A, B) If j.Value Like [B1].Value Then _ C.Value = C.Value + Share Else If j.Value Like "*" & [B1].Value & "*" And _ Len(j.Value) > Check Then C.Value = C.Value + Share / 2 Next j End Sub توزيع الاسهم V2.xlsm

اظن ان الكود المقترح سهل وغير معقد على العموم تمت محاولة شرحه في المشاركة السابقة للفائدة تفضل اخي Sub Trhel() lr = Range("b" & Rows.Count).End(xlUp).Row r = Range("b7:b" & lr).Find("*" & [b1].Value & "*", , , 1).Row c = Rows(6).Find([b2], , , 1).Column Cells(r, c) = Val(Cells(r, c)) + Val([b3]) End Sub

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Sub Update_amounts3() Dim Names$, Amount$, months$, i As Byte Dim tmp As Range, OneRng As Range, arr As Range Set f = Sheets("حركة الأقساط") ' الاسم Names = "*" & [b1].Value & "*" ' الشهر months = [b2] 'المبلغ Amount = [b3] With f ' التحقق من وجود قيمة في خلايا (الاسم-الشهر-المبلغ) Set arr = Union(.[b1], .[b2], .[b3]) For i = 1 To arr.Count If arr(i) = Empty Then MsgBox ("يرجى إضافة" & _ " " & arr(i).Offset(, -1).Value), 16, "إنتباه": Exit Sub Next ' تنفيد الكود عند التحقق من وجود قيمة رقمية في خلية المبلغ If Not IsNumeric(Amount) Then: Exit Sub 'نطاق البحث عن الاسم Set OneRng = .Range("b7", .Range("b" & .Rows.Count).End(xlUp)).Find(Names) 'نطاق البحث عن الشهر Set tmp = [C6:N6].Find(months) ' صف وجود الاسم A = OneRng.Row ' عمود وجود الشهر B = tmp.Column ' الخلية الهدف Set c = Cells(A, B) 'قيمة الخلية الهدف + قيمة المبلغ c.Value = c.Value + Amount End With End Sub ترحيل + جمع V2.xlsm

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

Private Sub TextBox1_change() Dim n As Range, J As Long, i As Long Dim Search As String Dim MyArray() As Variant SearchColumn = "A" Search = Me.TextBox1 MyArray = Array("Sheet1", "Sheet2") For i = LBound(MyArray) To UBound(MyArray) With Worksheets(MyArray(i)) Set n = .Columns(SearchColumn).Find(Search, LookIn:=xlValues, lookat:=xlWhole) If Not n Is Nothing Then J = n.Row: Me.TextBox2 = .Range("B" & J) Exit For Else Me.TextBox2 = "" End If End With Next i End Sub

وعليكم السلام ورحمة الله و بركاته Private Sub TextBox1_change() Dim n As Range, J As Long Dim Search As String Dim SearchColumn As Variant Dim ws As Worksheet: Set ws = Sheets("Sheet1") SearchColumn = "A" Search = Me.TextBox1 With ws Set n = .Columns(SearchColumn).Find(Search, LookIn:=xlValues, lookat:=xlWhole) If Not n Is Nothing Then J = n.Row: Me.TextBox2 = .Range("B" & J) Else Me.TextBox2 = "" End If End With End Sub

وعليكم السلام ورحمة الله و بركاته Private Sub TextBox1_change() Dim WS As Worksheet Dim n As Range, J As Long Dim Search As String Dim SearchColumn As Variant For Each WS In ThisWorkbook.Worksheets Search = Me.TextBox1 SearchColumn = "A" With WS Set n = .Columns(SearchColumn).Find(Search, LookIn:=xlValues, lookat:=xlWhole) If Not n Is Nothing Then J = n.Row: Me.TextBox2 = .Range("B" & J) Exit For Else Me.TextBox2 = "" End If End With Next WS End Sub

Private Sub UserForm_Initialize() Label5.Caption = [j1] End Su '******************* Private Sub TextBox1_Change() Dim n As Range, J As Long, f As Long Set WS = Worksheets("Sheet1") Cnt = Me.TextBox1.Value: WS.[W1] = Cnt f = WS.Cells(WS.Rows.Count, 2).End(xlUp).Row If Cnt <> "" Then With WS Set n = .Range("A2:A" & f).Find(What:=Cnt, LookIn:=xlValues, LookAt:=xlWhole, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False) If Not n Is Nothing Then J = n.Row Me.TextBox2 = .Range("B" & J) Me.TextBox3 = Evaluate("=SUMPRODUCT((D2:D10000) * (A2:A10000=W1) * (C2:C10000<>j1))") End If End With Else Me.TextBox3 = "": Me.TextBox2 = "" End If End Sub 'OR============================================================= Public Property Get WS() As Worksheet: Set WS = Worksheets("Sheet1") End Property Private Sub UserForm_Initialize() Set J = CreateObject("Scripting.Dictionary") a = WS.Range("A2:A" & WS.[A65000].End(xlUp).Row) For i = LBound(a) To UBound(a) If a(i, 1) <> "" Then J(a(i, 1)) = "" Next i n = J.keys Me.ComboBox1.List = n Label5.Caption = [j1] End Sub Private Sub ComboBox1_Change() Dim n As Range, J As Long, f As Long Cnt = Me.ComboBox1.Value: WS.[W1] = Cnt '''Code..... Else Me.TextBox3 = "": Me.TextBox2 = "" End If End Sub Sumif v2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Sumif.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Sub SAVERANGEPDF() Dim FilePath As String Dim filename As String 'filename = ActiveSheet.Name & "_" & Format(Now, "dd-mm-yyyy") & ".pdf" 'OR filename = ThisWorkbook.Name & "_" & Format(Now, "dd-mm-yyyy") & ".pdf" FilePath = Application.ActiveWorkbook.Path & Application.PathSeparator & filename Selection.ExportAsFixedFormat Type:=xlTypePDF, filename:=FilePath, _ Quality:=xlQualityStandard, IgnorePrintAreas:=False, OpenAfterPublish:=True End Sub

العفو اخي @AMIRBM يسعدنا اننا استطعنا مساعدتك اليك هدا الاقتراح بطريقتي مع تحديث اسماء الشهور بدون الحاجة لوضعها في عمود مستقل Option Explicit Dim myFormat(1) As String Dim Arr As Variant Private Sub UserForm_Initialize() Dim OneRng(), i As Integer, n As Integer Dim f As Worksheet: Set f = Sheets("1") '<====' نطاق البيانات OneRng = f.Range("A3:F" & f.Range("B" & f.Rows.Count).End(xlUp).Row).Value ListBox1.List = OneRng cbxShtName.Value = f.Name With ListBox1 .ColumnCount = 6 .ColumnWidths = "60;170;140;90;90;90" .BorderStyle = fmBorderStyleSingle End With '<====' رؤوس الاعمدة For i = 1 To 6: Me("label" & i) = f.Cells(2, i): Next i End Sub '========================= Private Sub colRecherche(Tbl As Long, Cpt As Long) Dim cnt As Long, dict As Long cnt = UBound(Arr, 2) With ListBox1 .AddItem For dict = 1 To cnt .List(Tbl, dict - 1) = Arr(Cpt, dict) Next dict .List(Tbl, 1) = Format$(.List(Tbl, 1), _ "dddd, mmmm dd, yyyy") '<====' التاريخ .List(Tbl, 4) = Format$(.List(Tbl, 4), "0.00") '<====' مبلغ الوحدة .List(Tbl, 5) = Format$(.List(Tbl, 5), "0.00") '<====' المجموع End With End Sub '========================= Private Sub Filtre() Dim Cpt As Long, dict As Long, tmp As Long, cnt As Long, n As Long Dim Clé As Boolean, Réf As Boolean, sFilter As String Clé = Len(ComboBox1.Value) Réf = Len(tbxSearch) tmp = UBound(Arr, 1): cnt = UBound(Arr, 2) With Me.ListBox1 If .ListCount > 0 Then .RowSource = "" .Clear End If 'فلترة باسم الشهر If Clé Then sFilter = ComboBox1.Value For Cpt = 3 To tmp If Clé Then If Format(CDate(Arr(Cpt, 2)), "mmmm") Like sFilter Then colRecherche n, Cpt n = n + 1 End If Else colRecherche n, Cpt n = n + 1 End If Next Cpt If Réf Then 'فلترة باسم البضاعة sFilter = tbxSearch For n = .ListCount - 1 To 0 Step -1 If Not UCase(.List(n, 2) Like UCase("*" & sFilter & "*")) Then .RemoveItem (n) End If Next n End If End With Count.Caption = ListBox1.ListCount: SumColumns End Sub '========================= Private Sub cbxShtName_Change() Dim xMonth As Object 'اسماء الشهور المتوفرة Dim Cpt As Long, tmp As Long Dim WS As Worksheet: Set WS = Sheets("1") With WS.Range("A1:F" & WS.[B650000].End(xlUp).Row) Arr = .Value tmp = UBound(Arr, 1) Filtre Set xMonth = CreateObject("Scripting.Dictionary") xMonth("*") = "" For Cpt = 3 To tmp ' '<====' تنسيق اسم الشهر xMonth(Format(CDate(Arr(Cpt, 2)), "mmmm")) = Empty Next Cpt Me.ComboBox1.List = xMonth.keys End With End Sub '========================= Private Sub CommandButton1_Click() Dim WS As Worksheet: Set WS = Sheets("2") If ListBox1.ListCount = 0 Then: Exit Sub If MsgBox("ترحيل البيانات" & " ؟", vbYesNo) = vbNo Then Exit Sub WS.Range("B5:G" & WS.Rows.Count).ClearContents WS.[b5].Resize(Me.ListBox1.ListCount, 6) = Me.ListBox1.List End Sub تنسيق الشهر V2.xlsb

قم بحذف الارتباط الذي وضعته من قبل من الكومبوبوكس (rowsource moi) للحصول على أسماء الشهور كما سبق الذكر طريقة فلترة البيانات خاطئة حاول شرح ما تحاول فعله ربما نستطيع مساعدتك

وعليكم السلام ورحمة الله تعالى وبركاته بعد معاينة الملف اظن انك في حاجة الى اعادة النظر في طريقة جلب البيانات الى الليست بوكس اما بخصوص تنسيق الشهر يمكنك تجربة شيء كهدا سيوفي بالغرض Private Sub UserForm_Initialize() Dim cel As Range Set f = Sheets("2") ' For Each cel In f.Range("S4:S" & f.[S65000].End(xlUp).Row) 'OR For Each cel In Range("moi") If cel.Value <> "" Then ComboBox1.AddItem Format(cel, "mmmm") End If Next cel End Sub

تفضل جرب المرفق التالي واختار ما يناسبك Private Sub UserForm_Initialize() Me.ScrollHeight = Me.Height * 2 End Sub 'OR Private Sub UserForm_Initialize() Me.ScrollHeight = Me.Height Me.Height = Me.Height / 2 End Sub 'OR Private Sub UserForm_Activate() With Me .ScrollBars = fmScrollBarsHorizontal .ScrollWidth = .InsideWidth * 1.5 End With End Sub test (1).xlsm

جرب هذا Private Sub TextBox1_change() Dim n As Range, J As Long, f As Long Set WS = Worksheets("Sheet1") clé = Me.TextBox1 f = WS.Cells(WS.Rows.Count, 2).End(xlUp).Row With WS Set n = .Range("A2:A" & f).Find(What:=clé, LookIn:=xlValues, LookAt:=xlWhole, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False) If Not n Is Nothing Then J = n.Row Me.TextBox2 = .Range("B" & J) Else Me.TextBox2 = "" End If End With End Sub بطريقة مختلفة Public Property Get WS() As Worksheet: Set WS = Worksheets("Sheet1") End Property Private Sub UserForm_Initialize() Set J = CreateObject("Scripting.Dictionary") a = WS.Range("A2:A" & WS.[A65000].End(xlUp).Row) For i = LBound(a) To UBound(a) If a(i, 1) <> "" Then J(a(i, 1)) = "" Next i n = J.keys Me.ComboBox1.List = n End Sub '================== Private Sub ComboBox1_Change() Me.TextBox2 = Evaluate("=vlookup(" & """" & Me.ComboBox1.Value & """" & _ ",A2:B" & Split(WS.[a2].CurrentRegion.Address, "$")(4) & ",2)") End Sub test.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Private Sub addbtn_Click() Dim n As Long Dim src As Worksheet: Set src = Sheets("Data") n = Application.WorksheetFunction.CountA(src.Range("B:B")) + 1 If Me.studname = "" Then: Exit Sub src.Cells(n, 2) = Me.cod.Value src.Cells(n, 3) = Me.studname.Value src.Cells(n, 4) = Me.row.Value src.Cells(n, 5) = Me.class.Value src.Cells(n, 6) = Me.group.Value src.Cells(n, 7) = Me.studcase.Value src.Cells(n, 8) = Me.birthdate.Value src.Cells(n, 9) = Me.mother.Value src.Cells(n, 10) = Me.gender.Value src.Cells(n, 11) = Me.mobile.Value src.Cells(n, 12) = Me.subcase.Value src.Cells(n, 13) = Me.adress.Value src.Cells(n, 14) = Me.datenow.Value src.Cells(n, 15) = Me.employ.Value src.Cells(n, 16) = Me.notes.Value With src.Range("A2:A" & src.Cells(src.Rows.Count, "B").End(xlUp).row) .Value = Evaluate("ROW(" & .Address & ")") End With arr = Array("studname", "cod", "row", "birthdate", "class", "studcase", "mobile", _ "notes", "group", "mother", "gender", "subcase", "adress") For i = 0 To UBound(arr): Me.Controls(arr(i)).Value = Empty: Next i MsgBox "تمت عملية التسجيل بنجاح" 'ActiveWorkbook.Save End Sub دوبل كليك على الصف الاول من ورقة Data لاظهار اليوزرفورم Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Application.Intersect(Target, Range("A1:P1")) Is Nothing Then Cancel = True ADD.Show End If End Sub school data 2025x V2.xlsm