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

وعليكم السلام ورحمة الله تعالى وبركاته Sub lastname() ' اخر اسم على الجدول Dim ws As Worksheet: Set ws = ActiveSheet Dim myRng As Range Set myRng = ws.Range("C4", Range("c" & Rows.Count).End(4)).SpecialCells(xlCellTypeFormulas, 2) With myRng myRng.Cells(myRng.Rows.Count, 1).Select End With End Sub ''''''''''''''''''''''''''''''''''''''''''''''' Sub lastname2() ' اخر صف في الجدول Columns("C").Find(What:="*", LookIn:=xlValues, SearchDirection:=xlPrevious).Select End Sub كود اول واخر اسم.xlsm

إذا كان هذا الشكل البيضاوي الذي تريده استخدم الشفرة التالية Private Sub Detail_Print(Cancel As Integer, PrintCount As Integer) Me.ScaleMode = 6 '// Millimeters Me.Circle (50, 5), 18, vbMagenta, , , 0.26 '// 0.1 To 1.0 End Sub db1.accdb

حيث ان الموضوع لم يحظ باهتمام الاساتذة الكرام ارفق مثال بعد تعديل كود الاستاذ دروب بالتعديلات التالية الاختيار يكون من مربع قائمة متعددة الاختيار لمادة او اكثر او الكل يمكن اختيار الادارة او تركه فارغ ليتم فلترة كل الادارات اخيرا لا اهتم باختيار اسماء المتغيرات لتكون معبرة عن وظيفة كل منها كما يفعل الاساتذة والخبراء وانما اختار اي اسم او حرف وامور اخرى لا يتسع المجال للحديث عنها وعلى كل حال خذ ماتريد او اترك الاخ شايب 🌹 stu(1).accdb

مارايك بدلا من تكرار الكود نستعين بتعديل الاخ @jjafferr على مشاركة سابقة للاخ العزيز شايب ويتم الاستدعاء عند تحديث المادة Function tx_degree(ctl As Control) Dim a As Integer Dim ctl_n As String Dim rs As Recordset Set rs = Me.RecordsetClone ctl_n = Replace(ctl.Name, "deg_", "") rs.MoveLast R = rs.RecordCount rs.MoveFirst For i = 1 To R rs.Edit rs(ctl_n) = ctl.Value rs.Update rs.MoveNext Next Me.Refresh End Function ثم في حدث بعد التحديث لكل حقل من حقول ادخال الدرجات نضع الامر Call tx_degree(deg_Arab) deg_Arab يتم تغييرها باسم الحقل مرفق الملف تم تغيير اسماء الحقول الثلاثة لتسهيل تنفيذ الامر بدلا من كتابة اسطر اضافية ادراج قيمة.accdb

وعليكم السلام ورحمة الله وبركاته تم التطبيق على عمود اللغة العربية ، أكمل بقية اعمدتك على المنوال نفسه Dim i As Integer, R As Integer Dim rs As Recordset Set rs = Me.RecordsetClone rs.MoveLast R = rs.RecordCount rs.MoveFirst For i = 1 To R rs.Edit rs!Arab = deg_A rs.Update rs.MoveNext Next Me.Refresh ادراج قيمة.rar

#If Vba7 Then Private Declare PtrSafe Sub ChooseColor Lib "msaccess.exe" Alias "#53" (ByVal hwnd As Long, rgb As Long) #Else Private Declare Sub ChooseColor Lib "msaccess.exe" Alias "#53" (ByVal hWnd As Long, rgb As Long) #End If Function DialogColor(rgb As Long) As Long Call ChooseColor(Application.hWndAccessApp, rgb) DialogColor = rgb End Function كلامك صحيح، تم التصحيح.

وعليكم السلام جرب أيضا New Microsoft Excel Worksheet01.xlsx

ملاحظاتي: - أتعبني تحويل رقم اللون الطويل إلى هيكس Hex أرقام سداسية إن صح التعبير واضطررت لعمل دالة لمعالجة مخرجات الدالة الأصل. - لم أصل إلى نوع مقاس الخط لأتمكن من حويلة بشكل دقيق فاضطررت لاستخدام رقم تقريبي بتقسيمه على 3.5 . - استخدمت كل خصائص الخط في صندوق كلمة/نص البحث ما عدا اسم الخط. - حاليا تبديل خصائص الخط في صندوق البحث يدويا (في طور التصميم) ويمكنكم إضافة تعديله بواسط الأزرار والخيارات في طور التشغيل. - مسموح للجميع التطوير فيه مباشرة وبدون إذن. - الدالة مصممة ليستفاد منها في الاستعلامات وفي الجداول لحقول المذكرة. Option Compare Database Option Explicit Function myHex(Color As Long) As String Dim hexStr As String hexStr = Hex(Color) If Len(hexStr) = 6 Then hexStr = Right(hexStr, 2) & Mid(hexStr, 3, 2) & Left(hexStr, 2) Else hexStr = Left(Right(hexStr, 2) & Left(hexStr, Len(hexStr) - 2) & "000000", 6) End If myHex = "#" & hexStr End Function Function RichText(ByVal sText As Variant, frmCtl As String) As String Dim sWord As String Dim lStr As String Dim rStr As String Dim sPos As Integer Dim fSize As Double sPos = InStr(1, frmCtl, ",") With Forms(Left(frmCtl, sPos - 1)).Controls(Right(frmCtl, sPos + 1)) sText = PlainText(Nz(sText, "")) sWord = PlainText(Nz(.Value, "")) rStr = "</font>" lStr = "<font color=""" & myHex(.ForeColor) & """>" sText = Replace(sText, sWord, lStr & sWord & rStr, 1) 'sText = Replace(Replace(sText, rStr & " " & lStr, " ", 1), rStr & "" & lStr, "", 1) lStr = "<font style='BACKGROUND-COLOR:" & myHex(.BackColor) & "'>" sText = Replace(sText, sWord, lStr & sWord & rStr, 1) fSize = .FontSize / 3.5 'تحويل تقريبي lStr = "<font size=" & fSize & "pt>" sText = Replace(sText, sWord, lStr & sWord & rStr, 1) If .FontBold Then lStr = "<b>": rStr = "</b>" sText = Replace(sText, sWord, lStr & sWord & rStr, 1) End If If .FontItalic Then lStr = "<i>": rStr = "</i>" sText = Replace(sText, sWord, lStr & sWord & rStr, 1) End If If .FontUnderline Then lStr = "<u>": rStr = "</u>" sText = Replace(sText, sWord, lStr & sWord & rStr, 1) End If End With RichText = sText End Function RichTextHighlight_01.accdb

لا تستطيع تغيير لون التظليل ولا الخط.

السلام عليكم اليك التعديل هل هو المطلوب ؟ S&M_22.rar

شكرا جزيلا استاذنا ، وكتب اجرك ، وفيت وكفيت

خالص الشكر على معلمنا الخبير الفاضل AbuuAhmed

تشتتي زاد مع هذا الموضوع 😞 النسخ مرة أخرى بعد تصحيح الخطأ الأخير. RichText_Memo_07.accdb RichText_Query_07.accdb PlainText_Sel_07.accdb

وعليكم السلام 🙂 1. الخطأ في هذا السطر فانت طلبت التركيز ينتقل الحقل xtdAmt ، بينما لا يوجد حقل في النموذج الفرعي بهذا الاسم. 2. انت عملت المعادلة التالية ، والتي تعمل بطريقة صحيحة ، ولكن قيمة المتغير xtdAmt = صفر ، لهذا السبب لا تتغير قيمته ظاهرا ، بينما قد تم اضافة صفر الى 100 واصبحت القيمة = 100 : 'update Customer Current Balance Forms!arEnterPayments!cmCurBalA = Forms!arEnterPayments!cmCurBalA + tdAmt

وعليكم السلام في موضوعك السابق ، اشرت لك على الرابك الذي به الاوامر الصحيحة : وبما انك مُصر على استعمال الكود الذي لديك ، اليك المشكلة : الاكسس يحفظ السجلات تلقائيا عند خروجك من السجل ، وانت تقول له برمجيا اذا كان هناك اي شيء في السجل تم تغييره (If Frm.Dirty Then) ، فاعطني الرسالة اعلاه

السلام عليكم 🙂 عمل جميل اخوي ابوخليل ، والحاجة اليه ماسة ، وان شاء الله اقوم بتجربته 🙂 جعفر

هذه المشكلة تحدث داخل الواتس أن الواتس يبحث عن الرقم فإن وجده فتح صفحة التحرير وانتقل اليها ، وان لم يجده تبقى صفحة التحرير غير فعالة ، ومن هنا يأتي تراكب وتراكم الأوامر داخل مربع البحث . أرى ان الحل يأتي من اكسس وهو ان لا يرسل الا الأرقام المسجلة في الواتساب . وذلك بمحاولة ايجاد كود يفحص الارقام قبل ارسالها ويستبعد غير المسجل

هذا توزيع حسب ناتج عملية عدد الوثائق * عدد المواد الوثائقXالمواد.xlsx

فك حماية كل أوراق العمل ThisWorkbook.unprotect "123456" حماية كل أوراق العمل ThisWorkbook.protect "123456" فك حماية الورقة النشطة ActiveSheet.unprotect Password:="123456" حماية الورقة النشطة ActiveSheet.protect Password:="123456" الأفضل تستخدم فك وحماية الورقة التي تحتاج التعامل معها. لأن فك جميع أوراق العمل يسبب بطئ .

تفضل Sub Copy_My_Data() Dim wsDest As Worksheet Dim LR As Long, LR1 As Long Dim msg As VbMsgBoxResult Dim Rng As Range, wsCopy As Worksheet msg = MsgBox(" ترحيل البيانات الى مصنف أحمد ؟", vbYesNo + vbQuestion + vbDefaultButton2, "تأكيد") If msg = vbYes Then Application.ScreenUpdating = False Set wsCopy = Sheets("Sheet1") With wsCopy LR = .Cells(Rows.Count, 3).End(xlUp).Row Set Rng = .Range(.Cells(10, "C"), .Cells(LR, "L")) End With Set wsDest = Workbooks.Open(ThisWorkbook.Path & "\أحمد.xlsm").Sheets("Sheet9") LR1 = wsDest.Cells(wsDest.Rows.Count, "C").End(xlUp).Row + 1 If wsDest.Range("C10") = Empty Then Rng.Copy wsDest.Range("C10").PasteSpecial Paste:=xlPasteValues Else Rng.Copy wsDest.Range("C" & LR1).PasteSpecial Paste:=xlPasteValues End If Set WS = Workbooks("أحمد.xlsm").Sheets("Sheet1") WCopy = WS.Cells(WS.Rows.Count, "C").End(xlUp).Row WDest = wsDest.Cells(wsDest.Rows.Count, "C").End(xlUp).Offset(1).Row WS.Range("C10:L" & WCopy).Copy wsDest.Range("C" & WDest).PasteSpecial Paste:=xlPasteValues [C10].Select Application.CutCopyMode = False Workbooks("أحمد.xlsm").Close True Application.ScreenUpdating = True End If End Sub Saad2.rar

شكرا لكل من ساهم بالاجابات الأخ شايب الأخ دروب مبرمج الأخ شامل٢

وعليكم السلام ورحمة الله تعالى وبركاته بعد المعاينة يبدوا لي انك بحاجة لتعديل اكواد اليوزرفورم 1 و 2 لانهم لهم نفس المشكلة عدم اظهار البيانات عند الانتقال الى ورقة الادخال تفصل اخي بالنسبة لليوزرفورم 1 قم باظافة الكود التالي Private Sub UserForm_Activate() Set f = Sheets("الدخول") Set d = CreateObject("Scripting.Dictionary") Set WSdata = f.[a3].CurrentRegion.Offset(1) ' العمود ("CF") Search_column = 84 For i = 3 To WSdata.Rows.Count clé = WSdata.Cells(i, Search_column): d(clé) = "" Next i On Error Resume Next Me.Combobox1.List = d.keys On Error GoTo 0 End Sub اما بالنسبة لليوزرفورم 2 قم بحدف جميع الاكواد الموجودة عليه وقم بنسخ الكود التالي Private Sub TextBox1_Change() Dim w As Integer, Last& If Me.TextBox1.Text = Empty Then Me.ListBox1.Visible = False ListBox1.Clear Else Me.ListBox1.Visible = True Last = Sheet2.Cells(Rows.Count, 4).End(xlUp).Row w = 0 For Each c In Sheet2.Range("D2:D" & Last) If c Like Me.TextBox1.Text & "*" Then Me.ListBox1.AddItem Me.ListBox1.List(w, 0) = Sheet2.Cells(c.Row, 4).Value w = w + 1 End If Next c End If End Sub Private Sub CommandButton2_Click() Dim sh1 As Worksheet, f As Range Set sh1 = Sheet2 With Me.cl If .Value = Empty Then Exit Sub End If Set f = sh1.Range("D:D").Find(.Value, , xlValues, xlWhole, , , False) If Not f Is Nothing Then Me.fk.Value = sh1.Range("H" & f.Row).Value Me.fm.Value = sh1.Range("I" & f.Row).Value Me.fq.Value = sh1.Range("J" & f.Row).Value End If End With End Sub Private Sub ListBox1_Click() Me.cl.Text = Me.ListBox1.Column(0) Me.ListBox1.Visible = False Me.TextBox1.Text = "" End Sub Private Sub CommandButton1_Click() Unload Me End Sub مخزون V2.xlsm

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

وعليكم السلام-جرب الملف الأن حضور وإنصراف.xlsb

اخي @2saad كل موضوع له طلب واحد تم غلق الموضوع

لقد تمت الاجابة فعلا على طلبك انت الان تطلب شيء مغاير لا علاقة له بالكود المرفق على ما اظن 2) ممكن توضح سؤالك اكثر عايز ترحل ايه بالظبط وفين

وعليكم السلام ورحمة الله تعالى وبركاته Sub Copy_to_another_workbook() Dim ShData As Worksheet, ShDest As Worksheet Dim aRws As Variant, aCols As Variant, lr As Long Const ShCool As String = "3 4 5 6 7 8 9 10 11 12 13" Set ShData = Worksheets("Sheet1") Application.ScreenUpdating = False 'نفس مسار الملف المفتوح Set ShDest = Workbooks.Open(ThisWorkbook.Path & "\أحمد.xlsm").Sheets("Sheet1") lastrow = ShDest.Cells(ShDest.Rows.Count, "C").End(xlUp).Row + 1 ' لتحديد مسار معين قم بتعديل هدا السطر بما يناسبك ' Set ShDest = Workbooks.Open("C:\Users\MOHAMMED HICHAM\Desktop\أحمد.xlsm").Sheets("Sheet1") lr = ShData.Columns("C:L").Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row aRws = Evaluate("row(10:" & lr + 10 & ")") aCols = Split(ShCool) If ShDest.[C10] = Empty Then ShDest.Range("C10").Resize(lr, UBound(aCols)).Value = Application.Index(ShData.Cells, aRws, aCols) Else ShDest.Range("C" & lastrow).Resize(lr, UBound(aCols)).Value = Application.Index(ShData.Cells, aRws, aCols) End If Workbooks("أحمد.xlsm").Close True Application.ScreenUpdating = True End Sub Saad.rar

يمكن أن تضع أمرين في كل كود من أكوادك، الأول في بداية الكود يقوم بإلغاء الحماية عن الورقة التي يتم تطبيق الكود عليها، والأمر الثاني في نهاية الكود يقوم بإعادة حماية الورقة بالكلمة السرية نفسها...