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

السلام عليكم و رحمة الله و بركاته ماشاء الله عليكم اساتذة الكرام على حلولكم الرائعة حبيت اشارككم فكرة بسيطة الا وهي استغناءعن وضع سطر On Error Resume Next في الكود باستخدام دالة Val لمقارنة معايير قيمة حقل رقمي مع قيمة حقل نصي كما هو في مثال التالي Dim strSql As String strSql = "[Key] = " & Val([txtSearch]) strSql = strSql & " OR [Number] = '" & Me![txtSearch] & "'" strSql = strSql & " OR [CardNumber] = '" & Me![txtSearch] & "'" DoCmd.SearchForRecord , , acFirst, strSql و أمر SearchForRecord بدلا من Recordset.Clone مجرد للاختصار في الكود و لكم مني أجمل تحايا

مشاركة مع اخي الاستاذ عمر حل آخر باستخدام التنسيق الشرطي sick2.rar

مشاركةً مع استاذي @ابوخليل ممكن وضع قيمة افتراضية ولتكن (0) ويصبح السطر الذي عليه اللون الأصفر كالتالي :- Me![reqcost]=Nz(Me!saPno.Column(5),0) إذا لم يجد قيمة فيعطيها (0) جرب ووافنا بارد .

عليكم السلام اعتقد لو وضعت هذا السطر في اعلى الكود سيتجاوز الخطأ ولن تظهر الرسالة ، ولكن لن يتم التحديث على الحقل On Error Resume Next

انا عادة لا اطرح حلولا لموضوع بادر بالاجابة عنه احد اخوتي .. خاصة الخبراء منهم .. ولكني كنت اعمل على المثال حينما كان الاستاذ عمر يشارك الأمر يسير : 1- افتح النموذج الفرعي على التصميم 2- انقر بزر الفأرة الأيمن على اي حقل 3- اختر من القائمة : التنسيق الشرطي اذا واجهاتك بالعربية او condition formating مؤكد ستتضح لك المسألة ملحوظة : انا قمت بتطبيق الشرط على جميع الحقول كل واحد على حدة كي يتم حماية السجل بالكامل يمكنك الاكتفاء بتطبيقه على حقل واحد

لا لم تحل لا فى الاصداؤ الاخير ولا اللى قبله

ارسل قاعدة بياناتك أخي الكريم

ايه الجمال ده ما شاء الله على الرغم انى جيت متأخر لكن تسلم ايدك على الهديه دي وال كنت بفكر فيها من فتره لكن كنت مكسل اعملها لكن انت عملتها باسلو وطريقه افضل من ال فكرت فيها وخليتها سهلة التعامل معها تسلم دماغك (ايه الحلاوة دي ايه الحلاوة دي ""مشهد من فلم مش فاكره"" ) ههههههههه جزاك الله كل خير عنا وجعله فى ميزان حسناتك

ما شاء الله تبارك الله ابداع ابداع ابداع سلمت يداك ودماغك دي ايه الحلاوة دي تصميم جميل والوان محتاج اتعلم الكثير منك فى موضوع الالوان واداء رائع تسلم ايدك وغفر لكم ولوالديكم يا رب العاليمن

فى النموذج الفرعي فى حدث فبل التحديث او ممكن ايضا فى الحال ضع هذا الكود Private Sub Form_BeforeUpdate(Cancel As Integer) If Me.cdatee = Date Then Exit Sub End If If InStr(Me.Doctor, "مؤجل") > 0 Then Exit Sub End If Undo MsgBox "غير مسموح بالتعديل على البيانات", vbExclamation Cancel = True End Sub هنا انا بتحقق من شرطين التاريخ وكلمة مؤجل اذا كان التاريخ يساوي تاريخ اليوم هيطلع من الاجراء ويكمل تحديث واذا كان هناك كلمة مؤجل فى اسم الطبيب هيكمل الاجراء ويحفظ اذا لا هيعيد القيمة القديمة ويلغي الحفظ جرب ورد علينا بالنتيجة

شكراً استاذي الفاضل هذا المطلوب ادم الله عليك من علمه وفضله لكم جزيل الشكر

هكذ هدايا والا فلا كنز من الأدوات والافكار بارك الله فيك وزادك علما ، وغفر لوالديك الذين انجبوا مثلك .. وغفر لنا ولك

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Sub Transfer() Dim srcRange As Range, Lr As Long, destCols As Variant Dim WS As Worksheet, dest As Worksheet, i As Integer Dim a(1 To 1, 1 To 7) As Variant Set WS = ActiveSheet Set dest = Sheets("كشف الحساب") a(1, 1) = WS.[B6].Value: a(1, 2) = WS.[C6].Value: a(1, 3) = WS.[D6].Value a(1, 4) = WS.[E6].Value: a(1, 5) = WS.[G6].Value: a(1, 6) = WS.[H6].Value: a(1, 7) = WS.[I6].Value destCols = Array("C", "D", "E", "F", "H", "I", "J") Lr = dest.Cells(dest.Rows.Count, "D").End(xlUp).Row + 1 For i = 0 To 6 dest.Cells(Lr, destCols(i)).Value = a(1, i + 1) Next i End Sub """""""""""""""""""""""""""""""""""""""""""""""""""""""""" Sub testCopy() Dim i As Integer, ScrWS As Worksheet, btn As Object Dim Sh As Worksheet: Set Sh = Sheets("البون") Application.ScreenUpdating = False Application.DisplayAlerts = False Application.CutCopyMode = False For i = 1 To 15 On Error Resume Next Set ScrWS = ThisWorkbook.Sheets(Sh.Name & i) If Not ScrWS Is Nothing Then ScrWS.Delete Next i For i = 1 To 15 Sh.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) Set ScrWS = ActiveSheet ScrWS.Name = Sh.Name & i ScrWS.DisplayRightToLeft = True For Each btn In ScrWS.Buttons: btn.Delete: Next btn On Error GoTo 0 Set btn = ScrWS.Buttons.Add(400, 20, 60, 30): btn.OnAction = "Transfer": btn.Caption = "ترحيل" Next i Sh.Activate Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub الايرادات والمصروفات.xlsm

بعد استاذنا الرائع / محمد هشام. اولا هذا المجهود بعد فضل الله يرجع للاستاذ محمد هشام و الاستاذ / حسونة حسين لقد تعلمنا منهما الكثير اسأل الله ان يمن عليهم بالخير الكثير هذا الكود VBA بدون ادخال صيغ حسابية فى ورقة العمل فى العمود G وشرحها كالاتى تعطيل الأحداث: نمنع حدوث أي تغييرات أخرى أثناء تنفيذ الكود لتجنب التكرار اللانهائي. التحقق من الخلية المتغيرة: نتأكد من أن الخلية التي تم تغييرها تقع في العمودين F أو E وأنها ضمن نطاق البيانات. التحقق من صحة البيانات: نتأكد من أن القيم المدخلة في الخليتين F و E هي أرقام. إذا كانت القيم غير رقمية، يتم عرض رسالة خطأ للمستخدم. حساب المجموع الكلي: نقوم بضرب قيمة الكمية في سعر الوحدة ونضع النتيجة في العمود G. تحديد ورقة العمل: يتم تحديد الورقة التي تحتوي على البيانات التي تريد تطبيق التنسيق الشرطي عليها. تحديد النطاق: يتم تحديد النطاق الذي يحتوي على القيم التي سيتم تطبيق التنسيق الشرطي عليها. في هذا المثال، يتم تطبيق التنسيق على العمود G بدءًا من الصف الثاني وحتى آخر صف يحتوي على بيانات. حذف التنسيق الشرطي الحالي: يتم حذف أي تنسيق شرطي موجود مسبقًا على النطاق المحدد. إضافة تنسيق شرطي جديد: يتم إضافة شرط جديد حيث يتم تلوين الخلايا باللون الأحمر إذا كانت قيمتها أقل من صفر (أي سالبة). تخصيص التنسيق: يمكنك تغيير لون الخط، حجم الخط، الخط العريض، والمائل وغيرها من خصائص التنسيق حسب رغبتك. Private Sub Worksheet_Change(ByVal Target As Range) ' تحديد ورقة العمل والعمود الأخير للبيانات Dim WS As Worksheet: Set WS = Sheets("فاتورة مبيعات") Dim Lr As Long: Lr = WS.Cells(WS.Rows.Count, "F").End(xlUp).Row ' تعطيل أحداث التغيير مؤقتًا لمنع التكرار اللانهائي Application.EnableEvents = False ' التحقق من أن الخلية المتغيرة تقع في العمودين F أو E If Not Intersect(Target, WS.Range("F:E")) Is Nothing Then ' التأكد من أن الصف المتغير ضمن نطاق البيانات If Target.Row <= Lr Then ' التحقق من أن القيم المدخلة هي أرقام If IsNumeric(Target.Value) And IsNumeric(WS.Cells(Target.Row, "E").Value) Then ' حساب المجموع الكلي وتعيينه في الخلية المناسبة WS.Cells(Target.Row, "G").Value = Target.Value * WS.Cells(Target.Row, "E").Value Call staining_negative_cells Else MsgBox "الرجاء إدخال قيم رقمية صحيحة في عمودي الكمية والسعر." End If End If End If ' إعادة تمكين أحداث التغيير Application.EnableEvents = True End Sub Sub staining_negative_cells() Dim WS As Worksheet Set WS = Sheets("فاتورة مبيعات") ' استبدل باسم الورقة التي تريدها ' تحديد النطاق الذي تريد تطبيق التنسيق الشرطي عليه With WS.Range("G2:G" & WS.Cells(WS.Rows.Count, "G").End(xlUp).Row) .FormatConditions.Delete .FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, Formula1:="0" With .FormatConditions(1).Font .Color = -16776961 ' لون أحمر .Bold = True End With End With End Sub طط.rar

جرب هدا Private Sub Worksheet_Change(ByVal Target As Range) Dim Lr As Long Dim WS As Worksheet: Set WS = Sheets("فاتورة مبيعات") Lr = WS.Cells(WS.Rows.Count, "F").End(xlUp).Row Application.EnableEvents = False For Each tmp In Target If Not Intersect(tmp, WS.Columns("F")) Is Nothing Or Not Intersect(tmp, WS.Columns("E")) Is Nothing Then If tmp.Row <= Lr Then WS.Cells(tmp.Row, "G").Formula = "=IF(AND(F" & tmp.Row & "<>"""", E" & _ tmp.Row & "<>""""), F" & tmp.Row & "*E" & tmp.Row & ", """")" End If End If Next tmp Application.EnableEvents = True Exit Sub Application.EnableEvents = True End Sub او Private Sub Worksheet_Change(ByVal Target As Range) Dim ColArr As Long, a As Variant, i As Long Dim WS As Worksheet: Set WS = Me On Error GoTo SubApp Application.EnableEvents = False Application.Calculation = xlCalculationManual ColArr = WS.Columns("E:G").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If Not Intersect(Target, WS.Range("E5:F" & ColArr)) Is Nothing Then a = WS.Range("E5:G" & ColArr).Value With WS For i = 1 To ColArr - 4 If IsNumeric(a(i, 1)) And IsNumeric(a(i, 2)) Then If Len(a(i, 1)) > 0 And Len(a(i, 2)) > 0 Then a(i, 3) = a(i, 1) * a(i, 2) Else a(i, 3) = "" End If Else a(i, 3) = "" End If Next i .Range("E5:G" & ColArr).Value = a End With End If SubApp: Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic End Sub طط.rar النتيجة قيم طط.rar

السلام عليكم يدويا او عن طريق كود Sub AlignTextBox() Dim ws As Worksheet Dim txtBox As Shape Dim rng As Range Set ws = ActiveSheet Set txtBox = ws.Shapes("TextBox1") Set rng = ws.Range("B2:D4") With txtBox .Left = rng.Left .Top = rng.Top .Width = rng.Width .Height = rng.Height End With End Sub Set txtBox = ws.Shapes("TextBox1") يمكن تعديل اسم التكست Set rng = ws.Range("B2:D4 تعديلها حسب المكان محاداة testbox.xlsb

من وجهة نظري كل المسميات تؤدي نفس الغرض (لأن الكلمة المختارة هي الثمن المعنوي لمن حل المشكلة ). المشكلة التي تتعبني شحصياً هي . أن يقوم صاحب الطلب لنسب الحل لنفسه بدون وجه حق وهم كُثر للأسف . أو الرد بشكراً دون اختيارها أيضاً . وهنا يأتي دور الرقابة في (التنبيه أو التصحيح) . وشكراً .