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

استخدم هذه المعادلة غير النطاق حسب الموجود لديك =SUM(SUMPRODUCT((LEN(A1:A444)>3)*1))

يمكنك استعمال هذه المعادلة للتوصل لتاريخ النهاية بعد 100 يوم عمل =WORKDAY.INTL($C$5-1,100,7) وهذه الدالة للإصدارات الأحدث (2010 وما بعدها) تراعي خيارات عطلة نهاية الاسبوع ورقم 7 يعني الجمعة والسبت ويمكن استخدام هذه الدالة للاصدارات الاقدم (2007 وما قبلها) =WORKDAY($c$5,100)-1 هذه الدالة تحسب عدد الأيام على ان اجازة نهاية الاسبوع هي السبت والاحد لذلك تم انقاص يوم من الناتج لتحسب على ان عطلة نهاية الاسبوع الجمعة والسبت ملحوظة: وتم تعديل الملف المرفق ليحسب عدد أيام العمل بين تاريخين للإصدارات القديمة بدالة networkdays والحديثة networkdays.intl بالتوفيق ايام عمل.xlsx

أبوأحمد سبقني 🙂 كيف استخدم زر الزيادة أو نقصان_02.xlsm

ما رأيك لو استبدلناها بزر تحكم عادي كيف استخدم زر الزيادة أو نقصان .xlsm

مادمت ستخفي اطار اكسس يمكنك الطباعة بدون عرض نعم حل جميل

مع عدم اقتناع اخونا شايب بفكرة الفلترة عند التغيير بداية في حدث عند التغيير نضع الامر On Error Resume Next Dim strWhere As String Dim strtxt As String If Me.X1.Text <> "" Then strtxt = Me.X1.Text strWhere = "[FATHER_NAME]&[NUM_PAID]&[DATE_PAID]&[INSTALLMENTS] like '*" & strtxt & "*'" Me.Filter = strWhere Me.FilterOn = True Else Me.Filter = "" Me.FilterOn = False End If Me.X1.SetFocus Me.X1.SelStart = Len(Me.X1.Text) وفي حدث عند مفتاح اعلى نضع الامر If KeyCode = 32 Then Me.X1.Value = Me.X1.Text & Chr$(32) Me.X1.SelStart = Len(X1.Text) End If وخطوة اضافية ليست مهمة في حدث عند النقر المزدوج نضع Me.X1 = "" Me.Filter = "" Me.FilterOn = False Me.X1.SetFocus الملف مرفق مع عدم الاقتناع والافضل من وجهة نظر الاخ شايب استخدام الفلترة في حدث بعد التحديث لكون الامر ينفذ مرة واحد ولكن للناس فيما يعشقون مذاهب اخيرا الاخ شايب ليس خبير ولا من اساتذة الموقع ومشاركاته تخطئ وتصيب وتخطئ اكثر مما تصيب والنقد مرحب به وخصوصا باني لم اراجع الملف بشكل جيد لكون مشاركتي بداية كانت تتعلق بجزئية عدم تكرار المعيار اخونا العزيز شايب 🌹 Aziz5_03.accdb

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

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

في المثال الاساسي يوجد خلل وكذلك في تعديلكم استاذ قاسم جرب تفلتر اسم من مقطعين اي بينهما مسافة مثلا ستجد المشكلة طبعا الحل متوفر انظر مشاركة استاذنا ابو احمد وتوجد طريقة اخرى في حدث عند مفتاح اعلى ايضا تكرار المعايير ليست خطأ ولكن بمكن اختصارها بامر واحد بدلا من Me.Form.Filter = "[QryPaids]![FATHER_NAME] LIKE '*" & filterText & "*' OR [QryPaids]![NUM_PAID] LIKE '*" & filterText & "*'" ممكن نكتب الامر هكذا strWhere = "[FATHER_NAME]&[NUM_PAID] like '*" & strtxt & "*'" وممكن نزيد الحقول لاي عدد بدون الحاجة لتكرار like و or هنا نبحث في اربعة حقول بمربع نص واحد strWhere = "[FATHER_NAME]&[NUM_PAID]&[DATE_PAID]&[INSTALLMENTS] like '*" & strtxt & "*'" وفي هذه الطريقة اضافة للبحث والفلترة المعروفة يمكن تقسيم البحث على الحقول مثلا نبحث عن احمد الذي يعمل في ادارة وباشر العمل بتاريخ ويكون البحث باستخدام "*" بالشكل التالي احمد*المالية*12/1/2018 و الحديث قد يطول ولكن نترك الامر للاساتذة الكرام فاهل مكة ادرى بشعابها اخير يعتقد اخونا شايب ان الفلترة اثناء الكتابة خيار غير جيد اذا كانت القاعدة تحتوي على عدد كبير من السجلات او اذا عملنا عن طريق الشبكة واعتذر عن وضع مرفق فمشاركتي تهتم بالجانب النظري اضافة لعدم اقتناعي بفكرة الفلترة عند التغيير اخونا شايب 🌹

تفضل شرائح (1).xlsx

السادة الافاضل لكم منى التحية اريد استفسار عن كيفية اضافة كود بالموديل الموجود بالملف المرفق Rows(2).RowHeight = 35 Rows("3:10").RowHeight = 25 على ان يكون هذا التنسيق بالملف المطلوب ترحيله بيان السولار اليومى لمزارع الامهات (1).xlsm

تفضل Sub PrintReceipt() Dim LRow As Long Dim namsh As String Dim wk, wk2 As Worksheet Dim x As Integer Dim check As Boolean namsh = "temp" Set wk = Worksheets("التكويد") For Each wk2 In Worksheets If wk2.Name Like namsh Then check = True: Exit For Next If check = False Then With ThisWorkbook .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = namsh End With End If Set wk2 = Worksheets(namsh) wk2.Range("A1:E9999") = "" LRow = wk.Range("A999").End(xlUp).Row wk.Range("A1:A" & LRow & ",E1:E" & LRow & ",R1:R" & LRow & ",S1:S" & LRow & ",T1:T" & LRow).Copy wk2.Range("A1") wk2.Columns("A:E").AutoFit With wk2 .PageSetup.PrintArea = "A1:E" & LRow .PrintOut , , , , True, , , , False 'أمر الطباعة End With ' حذف الورقة جديدة Application.DisplayAlerts = False If ThisWorkbook.Worksheets.Count = 1 Then MsgBox "There Is only One Sheet. The Deletion Can't Be Done!", vbCritical: Exit Sub If Evaluate("=ISREF('" & namsh & "'!A1)") Then Sheets(namsh).Delete End If Application.DisplayAlerts = True End Sub

نعم ممكن في حدث عند التحميل ضع Me.InsideHeight = 7000 Me.InsideWidth = 10000 الارقام غيرها للحجم الذي يناسبك ولا تنسى ان تعدل خصائص النموذج من تبويب تنسيق الى توسيط تلقائي نعم ونمط الحدود الى مربع حوار او رفيع وزري التصغير والتكبير الى بلا او تمكين التصغير حسب ما تريد اخونا شايب 🌹

قواعد المشاركة فى الموقع اضغط هنـــــــــامن فضلك لقراءة القواعد كاملة و بصفة خاصة نؤكدعلى ما يلي 1- يمنع منعا باتا نشر أية مواد تخالف حقوق الملكية الفكرية و يرجى الابلاغ عن المشاركات المخالفة من خلال زر تقرير اسفل المشاركة 2-يجب استخدام خاصيةالبحث قبل طرح السؤال توفيرا للوقت و الجهد. 3-ضرورة كتابة عنوان واضح للموضوع يدل على محتواه ويعطي وصفاً مختصرا للسؤال. 4-ممنوع منعا باتاً كتابة عناوين سينمائية مثل عاجل ، نداء الي فلان ، الي الخبراء ، طلب مساعدة ، أريد حلا..... 5-يمكن استعجال الرد باستخدام تعبير -للرفع- و غير مسموح بالالحاح او اللوم فجميع الاعضاء يشاركون تطوعا طبقا لسعة وقتهم. ومخالفة ذلك تعرض الموضوع للحذف هذا الموضوع مخالف لقوانين المنتدي ×××××××× يمنع منعا باتا توجيه السؤال إلى شخص بعينه لان هذا قد يدفع الآخرين إلى عدم الإجابة، والهدف هو التفاعل من الجميع. ×××××××× يغلق ××××××××

بسم الله الرّحمن الرّحمن الرحيم السلام عليكم ورحمة الله تعالى وبركاته إخوتي في الله؛ رُوّاد أوفيسنا المباركون؛ فيما يلي موقِعٌ هديّة خاصّة، لمن يعمل في مجال التّصميم والعروض التقديمية. موقع يحوي آلاف الرسومات الجاهزة مجانًا للموشن جرافيك والعروض التقديمية آلاف الرسومات الجاهزة مجانًا للموشن جرافيك لمشروعك القادم! رسومات توضيحية مجانية رائعة قابلة للتخصيص لمشروعاتك يُمكنك بتخصيص الرسوم التوضيحية وتحريكها وتنزيلها لإنشاء صفحات مخصصة، أو تطبيق أو عروض تقديمية رائعة! رابط الموقع https://storyset.com/ .......................... في أمان الله.

https://www.youtube.com/watch?v=whPFLS8acUY&feature

كل شيء ممكن في الاكسيل 1-تغيير اسماء الصفحات ليتعرف عليها الاكسل بشكل جيد من جهة ومن جهة ثانية اسهل في كتابة الكود ونسخه ولصقه 2-التاريخ في الخلية B15 يجب ان يكتب كتاريخ وليس تاريخ ومعه الحرف م 3- الخلايا المدمجة في الصف الأول لا أنصح بها (لانها تسبب مشاكل في تحديد اخر صف فيه بيانات) 4- اذا كان التاريخ خطأ B15 تحصل على رسالة يذلك و يتوقف الكود عن العمل الكود Option Explicit Sub tansform_data() Dim B As Worksheet, Var_sh As Worksheet Dim Jour%, Mois%, Last_row% Dim Spec_rg As Range Set B = Sheets("By_jour") Set Spec_rg = B.Range("A15") If Not IsDate(Spec_rg) Then MsgBox "You Enter a wrong Date Please Justify" Exit Sub End If Jour = Day(Spec_rg): Mois = Month(Spec_rg) Select Case Mois Case 4 Select Case Jour Case Is <= 15 Set Var_sh = Sheets("Ap1") Case Else Set Var_sh = Sheets("Ap2") End Select '+++++++++++++++++++++++++++++ Case 5 Select Case Jour Case Is <= 15 Set Var_sh = Sheets("May1") Case Else Set Var_sh = Sheets("May2") End Select '+++++++++++++++++++++++++++++ Case 6 Select Case Jour Case Is <= 15 Set Var_sh = Sheets("Jun1") Case Else Set Var_sh = Sheets("Jun2") End Select '+++++++++++++++++++++++++++++ Case 7 Select Case Jour Case Is <= 15 Set Var_sh = Sheets("Jul1") Case Else Set Var_sh = Sheets("Jul2") End Select Case Else Exit Sub End Select ' Var_sh.Select Last_row = Var_sh.Range("a:a").Find("", after:=Var_sh.Range("a3")).Row Var_sh.Cells(Last_row, 2).Resize(, 8).Value = _ B.Cells(12, 2).Resize(, 8).Value Var_sh.Cells(Last_row, 1) = Spec_rg End Sub الملف مرفق Tarhil_Youmi.xlsm

برجاء شرح مافعلته لتحديد مسار القاعدة وشكرا لك ....

يا أخي: لماذا لا تريد ان تصدق ان الكود يقوم ينسخ الخلايا المرئية فقط من الشيت recycle ,وينقلها الى الشيت invoice وذ لك بفضل ما هو باللون الاحمر في هذه 3 أسطر من الكود Worksheets("recycle").Range("a" & arr(x) & ":f" & arr2(x)).SpecialCells(xlCellTypeVisible).Copy Sheets("invoice").Range("a" & last_row).PasteSpecial Paste:=xlPasteValues Sheets("invoice").Range("a" & last_row).PasteSpecial Paste:=xlPasteFormats الصفحة الاساسية :recycle الصفحة المنقول اليها:invoice استبدل الكود بهذا كي لا تظهر( الساعة الرملية) اذا لم يكن في احد الفواتير "فاتورة مبيعات رقم" او "الاجمالي" فإن الكود يمسح البيانات من ورقة invoice و يتوقف عن العمل Option Explicit Sub Test_Me() Dim rngFind As Range Dim strFindMe$ Dim r%, r1%, x%, last_row%, k%, rr% Dim arr(), arr2() k = 1 last_row = 1 With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With On Error Resume Next Sheets("invoice").Cells.Clear strFindMe = "فاتورة مبيعات رقم" With Worksheets("recycle").Range("c:c") Set rngFind = .Find(what:=strFindMe, LookIn:=xlValues) If Not rngFind Is Nothing Then r = rngFind.Row ReDim Preserve arr(1 To k) arr(k) = r Do Until r = r1 Set rngFind = .FindNext(rngFind) r1 = rngFind.Row k = k + 1 ReDim Preserve arr(1 To k) arr(k) = r1 Loop End If ReDim Preserve arr(1 To k - 1) End With If r = 0 Then GoTo 1 '============================================ k = 1 r1 = 0: r = 0 strFindMe = "الاجمالي" With Worksheets("recycle").Range("a:f") Set rngFind = .Find(what:=strFindMe, LookIn:=xlValues) If Not rngFind Is Nothing Then rr = rngFind.Row ReDim Preserve arr2(1 To k) arr2(k) = rr Do Until r1 = rr Set rngFind = .FindNext(rngFind) r1 = rngFind.Row k = k + 1 ReDim Preserve arr2(1 To k) arr2(k) = r1 Loop End If ReDim Preserve arr2(1 To k - 1) End With If rr = 0 Then GoTo 1 If UBound(arr) <> UBound(arr2) Then GoTo 1 '============================================ For x = UBound(arr) To LBound(arr) Step -1 Worksheets("recycle").Range("a" & arr(x) & ":f" & arr2(x)).SpecialCells(xlCellTypeVisible).Copy Sheets("invoice").Range("a" & last_row).PasteSpecial Paste:=xlPasteValues Sheets("invoice").Range("a" & last_row).PasteSpecial Paste:=xlPasteFormats last_row = Sheets("invoice").Cells(Rows.Count, 1).End(3).Row + 2 Next 1: Erase arr: Erase arr2: Set rngFind = Nothing: strFindMe$ = vbNullString With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .CutCopyMode = False End With End Sub الملف مرفق Copy_Invoices Corriger.rar

الحمد لله , تم التوصل بفضل الله الى الحل الصحيح , و هذا هو الكود Private Sub Form_BeforeUpdate(Cancel As Integer) Dim m As Integer Dim ctl As Control Dim intnewrec As Integer intnewrec = Me.NewRecord If intnewrec = True Then MsgBox " you insert a new record " Else For Each ctl In Me.Controls If ctl.ControlType = acTextBox Or ctl.ControlType = acComboBox Then If ctl.OldValue <> ctl.Value Then m = InputBox(ctl.ControlName & " value already changed Enter your password to save ?") If m = 1 Then Cancel = false Else Cancel = true ctl.Undo End If End If End If Next ctl End If End Sub حيث في الأسطر من 4 الى سبعة اختبار فيما اذا كان السجل الذي تم تعديله هو سجل جديد أم لا , فاذا كان السجل جديد لا داعي لارسال رسالة عند تغيير أي حقل , فهذا يبدو عملا متعبا و عديم الفائدة , أما اذا كان السجل الذي تم تعديله مسجل سابقا , فانه يتم الانتقال في السطر 9 لعمل حلقة دورانية لفحص كافة عناصر التحكم ( شرط أن لا تكون عناوين أو صفحات أو غيرها ) فاذا وجد عنصرا قد تغيرت قيمته , يرسل رسالة تبين أن الحقل المسمى " " قد تغيرت قيمته , و يطالب بادخال كلمة سر للتأكد من صلاحية التعديل , فاذا كانت كلمة السر صحيحة يحفظ التعديلات , و الا يلغي التعديل و يعيد القيمة القديمة للعنصر و هكذا بالنسبة لبقية العناصر