نجوم المشاركات

وعليكم السلام ورحمة الله تعالى وبركاته بطريقة مختلفة Sub CopyRow_Item() Dim i&, j&, n&, cnt&, r&, lr&, a As Boolean Dim arr() As Variant, rCrit As Variant, rng As Variant Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("قاعدة العملاء") cnt = 2 With WS If [N1] = Empty Then MsgBox "اصحى و اكتب التاريخ", vbExclamation: Exit Sub Application.ScreenUpdating = False lr = .Columns("b:k").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row a = True n = 0 rng = .Range("B2:K" & .Range("B" & Rows.Count).End(xlUp).Row).Value cnt = .Cells(.Rows.Count, "AM").End(xlUp).Row ReDim arr(1 To UBound(rng), 1 To UBound(rng, 2)) For i = 1 To UBound(rng) If rng(i, 6) <> "" Or rng(i, 7) <> "" Then a = False n = n + 1 For j = 1 To UBound(rng, 2) arr(n, j) = rng(i, j) Next j End If Next i If n > 0 Then .Range("AM" & cnt + 1).Resize(n, UBound(arr, 2)) = arr cnt = cnt + n For r = 2 To lr Union(.Range("F" & r).Resize(, 2), .Range("I" & r)).ClearContents Next r Application.Goto .Range("AM" & 2), True: [N1] = "" End If End With Application.ScreenUpdating = True If a Then MsgBox "الرجاء إظافـــة التحصيلات", vbExclamation Else MsgBox "الحمد لله - تم ترحيل التحصيلات بنجاح " & vbNewLine & _ " مستر إيهاب الاسوانى", 64 End If End Sub كود ترحيل V3.xlsm

شكراً لك أخي الحبيب @ahmed draz على لطفك وكلماتك الطيبة .. المنتدى عامر بالمحبة الموصولة بين أعضائه 🥰 . ونتمنى أن نكون عند حسن الظن 💐

حتى اعرف ان المبرمج مجتهد فيه حاجات بديهية تستقبلك اول ما تفتح البرنامج على التصميم منها بدايات تسمية كائنات اكسس ... فالجداول تبدأ بــ tbl ، والنماذج بــ frm والاستعلامات بــ qry والتقارير بـــ rep انا وجهتك بان تعمله في نموذج مستمر ، وحتى اني لونته بالاحمر من اجل تاخذ بالك ... وعلى كل حال تم تغييره تفضل تم عمل التالي : 1- شاشة رئيسية مؤقتة ... بعد اكتمال البرنامج سوف نتعاون على تصميم شاشة احترافية . الشاشة الحالية تشتمل على زرين : - زر لإعداد الفصل الدراسي .... والاعداد هذا يجب ان يتم قبل ادخال الدرجات - زر لإدخال الدرجات سوف تلاحظ الضبط والاحكام في المسألة ................................................................................................................................................................ المطلوب منك بعد العمل على المثال والتجربة التالي : اشرح لنا كيف تمت العملية ... بمعنى : - اعطاء وصف وشرح عام للطريقة المتبعة في تنفيذ الفكرة ( الفكرة معتمدة على .. جدول / نموذج رئيس / نموذجين فرعيين ) - شرح خطوات تنفيذ العملية بالتفصيل ... مثلا من ضمن التفاصيل حقلين مخفيين في نموذج ادخال الدرجات تذكر ما الفائدة منهما . اعتبرني اتعلم منك .. الشرح هذا سيفيد كل من يمر على الموضوع من طلاب العلم اذا لم تشرح العملية بطريقة نشعر بها انك مستوعب لهذا الدرس فإني ارفع يدي عن الاستمرار بمعنى ان استمراري معك متوقف على هذا الطلب اعانك الله ووفقك .................................................................................................................................................................... Db4.rar

وعليكم السلام ورحمة الله تعالى وبركاته Option Compare Text Public Property Get F() As Worksheet: Set F = Worksheets("Sheet1") End Property Sub Sort_Category() Dim OneRng As Range Dim lr As Long lr = F.Cells(Rows.Count, "E").End(xlUp).Row Set OneRng = F.Range("A2:L" & lr) With OneRng .Sort Key1:=.Columns(5), Order1:=xlDescending, Header:=xlNo End With End Sub '***************************** Sub Filter_and_create_Sheets() Application.DisplayAlerts = False Application.ScreenUpdating = False F.[w1] = F.[E1] RngA = F.[A1].CurrentRegion.Rows.Count RngB = F.[A1].CurrentRegion.Columns.Count F.[A1].Resize(RngA, RngB).AdvancedFilter Action:=xlFilterCopy, _ CopyToRange:=F.[w1], Unique:=True For Each c In F.Range("W2:W" & F.[W65000].End(xlUp).Row) F.[W2] = c.Value On Error Resume Next Sheets(CStr(c.Value)).Delete On Error GoTo 0 Sheets.Add After:=Sheets(Sheets.Count) Set n = ActiveSheet n.Name = CStr(c.Value) n.DisplayRightToLeft = True F.[A1].Resize(RngA, RngB).AdvancedFilter Action:=xlFilterCopy _ , CriteriaRange:=F.[W1:W2], CopyToRange:=[A1] For r = 1 To 12 n.Cells.EntireRow.AutoFit n.Columns(r).ColumnWidth = F.Columns(r).ColumnWidth Application.ErrorCheckingOptions.NumberAsText = False Next Next c F.Activate End Sub تقرير صف أول 2025.xlsm

نعم صحيح ، فعلاً لا أحد يعلم ما الفائدة التي ينتظرها صاحب الموضوع من اخفاء هذا التنبيه وليس الفائدة من مربع الحوار ( رسالة جاري الطباعة ) 😁 فعلاً الويندوز سيحتاج لفرض صلاحيات من المستخدم ليتم تنفيذ أحد الطلبات التي تختص بنظام الويندوز ..

الاستاذ الفاضل محمد هشام. الف الف شكر لاهتمام حضرتك الكود يعمل و ينفذ المطلوب اكرر شكري لحضرتك

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Sub SaveActiveSheetVBA() Dim WS As Worksheet, NewWb As Workbook Dim SPath As Variant, FileName As String, fname As String Set WS = ThisWorkbook.Sheets("Sheet1") ' تحديد ورقة العمل SPath = ThisWorkbook.Path & "\" ' مسار الملف FileName = "TEST" ' اسم الملف fname = SPath & FileName With Application .DisplayAlerts = False .ScreenUpdating = False .CopyObjectsWithCells = False WS.Copy Set NewWb = ActiveWorkbook NewWb.SaveAs fname, FileFormat:=51 NewWb.Close False Set NewWb = Nothing .DisplayAlerts = True .CopyObjectsWithCells = True .ScreenUpdating = True End With End Sub Copy another Workbook.xlsm

تم التعديل في المشاركة السابقة

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

ألف شكر أخي الكريم على النصائح بالتأكيد ستكون مفيدة لي

اخى الكريم توقف الكود عند اختيار تغير كلمة المرور ' عند النقر على زر تغيير كلمة المرور Private Sub btn_changeclick_Click() On Error Resume Next ' إخفاء رسالة الخطأ في البداية Me.Lbl_incorrect.Visible = False ' التحقق من اختيار المستخدم If IsNull(Form_Movie_pag.txt_username) Or Form_Movie_pag.txt_username = "" Then Me.Lbl_incorrect4.Caption = "تحذير" Me.Lbl_incorrect3.Caption = "الرجاء اختيار المستخدم" Me.Lbl_incorrect4.Visible = True Me.Lbl_incorrect3.Visible = True Form_Movie_pag.txt_username.SetFocus Exit Sub

وعليكم السلام 🙂 حيا الله اخوي محمد 🙂 للتقارير التي تطبع على طابعات خاصة ، مثل طابعة الهويات البلاستيكية ، يجب تخصيص الطابعة ، ولا نجعلها الطابعة الافتراضية ، هكذا . . . ثم تجعل مسافات الحواف كلها صفر ، وسستم تغييرها تلقائيا حسب اعدادات الطابعة : . . ودائما استعمل "معاينة الطباعة" . . فيصبح تقريرك هكذا . جعفر

في حالة الرغبة باستخدام الكود الخاص بك يكفي تعديله فقط على الشكل التالي Sub PDF() Dim Path As String Path = Label2.Caption 'Code......................... ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _ Path & "ملف رواتب الموظفين\" & fName, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False End Sub

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي جرب هدا Private Sub CommandButton1_Click() Dim WS As Worksheet: Set WS = Sheet3 Dim FileName As String, strDirname As String, Patch As String, strDefpath As String strDirname = Me.TextBox1.Text FileName = WS.[B8] strDefpath = Label2.Caption lr = WS.Range("B" & WS.Rows.Count).End(xlUp).Row WS.PageSetup.PrintArea = "A1:D" & lr + 5 On Error Resume Next If FileName = "" Then MsgBox "يرجى اظافة اسم الملف": Exit Sub If Not Right(strDefpath, 1) = "\" Then strDefpath = strDefpath & "\" If Not Right(FileName, 4) = ".Pdf" Then FileName = FileName & ".Pdf" If Dir(strDefpath & strDirname, vbDirectory) = "" Then MkDir strDefpath & strDirname Patch = strDefpath & strDirname & "\" & FileName WS.ExportAsFixedFormat Type:=xlTypePDF, FileName:=Patch End Sub ملف V2.xlsm