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

السلام عليكم 🙂 هذا الموقع يعطي ترتيب أكثر قواعد بيانات العالم استخداما: https://db-engines.com/en/ranking/relational+dbms والترتيب متغير شهريا ، ففي هذا الشهر: 6/2024 ، يكون ترتيب الاكسس رقم 8 عالميا : . واليكم طريقة تقييمهم للترتيب من: https://db-engines.com/en/ranking_definition وهنا تمت ترجمته آليا الى العربية: جعفر

اخي بما انك تريد انشاء قاعدة بيانات لتعبئة عناصر اليوزرفورم بشكل ديناميكي ومترابط اسهل طريقة بالنسبة لك هي انشاء جدول على ورقة Compte magasin يتضمن جميع الاعمدة المرغوب الاشتغال عليها مع حدف جميع الاعمدة الفارغة وتسميته مثلا ب Table1 واستبدال الاكواد الموجودة على النمودج لديك بالكود التالي شكل الملف بعد التعديل '24/06/2024 by:MOHAMEED HICHAM www.officena.net "منتدى الاكسيل" ' Dim a, i As Long Dim d As Object, ComboAry As Variant Private Const Cpt As String = "Compte magasin" Private Const tbl As String = "Table1" Private Sub UserForm_Initialize() a = Sheets(Cpt).ListObjects("Table1").DataBodyRange.Columns("A:X") Set d = CreateObject("scripting.dictionary") d.CompareMode = vbTextCompare ComboAry = Array("ComboBox1", "ComboBox3", "ComboBox5", "ComboBox9", "ComboBox12") For i = 0 To UBound(ComboAry): Me.Controls(ComboAry(i)).value = "*": Next i End Sub Private Sub ComboBox1_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) d(a(i, 2)) = "*" Next ComboBox1.List = d.keys End Sub Private Sub ComboBox2_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) If UCase(a(i, 2)) = UCase(ComboBox1.value) Then d(a(i, 3)) = "*" Next ComboBox2.List = d.keys End Sub Private Sub ComboBox3_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) d(a(i, 21)) = "*" Next ComboBox3.List = d.keys End Sub Private Sub ComboBox4_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) If UCase(a(i, 21)) = UCase(ComboBox3.value) Then d(a(i, 22)) = "*" Next ComboBox4.List = d.keys End Sub Private Sub ComboBox5_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) d(a(i, 23)) = "*" Next ComboBox5.List = d.keys End Sub Private Sub ComboBox11_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) If UCase(a(i, 23)) = UCase(ComboBox5.value) Then d(a(i, 24)) = "*" Next ComboBox11.List = d.keys End Sub Private Sub ComboBox9_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) d(a(i, 19)) = "*" Next ComboBox9.List = d.keys End Sub Private Sub ComboBox8_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) If UCase(a(i, 19)) = UCase(ComboBox9.value) Then d(a(i, 18)) = "*" Next ComboBox8.List = d.keys End Sub Private Sub ComboBox12_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) d(a(i, 4)) = "*" Next ComboBox12.List = d.keys End Sub Private Sub ComboBox13_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) If UCase(a(i, 4)) = UCase(ComboBox12.value) Then d(a(i, 5)) = "*" Next ComboBox13.List = d.keys End Sub '************************* Private Sub ComboBox1_Change() ComboBox2.value = "*" End Sub Private Sub ComboBox3_Change() ComboBox4.value = "*" End Sub Private Sub ComboBox5_Change() ComboBox11.value = "*" End Sub Private Sub ComboBox9_Change() ComboBox8.value = "*" End Sub Private Sub ComboBox12_Change() ComboBox13.value = "*" End Sub

أبشر بسعدك عمي @ابوخليل 😊🌹 أضفت زرين في نافذة إعداد اللعبة : طباعة اللعبة / طباعة الحل : التحميل 🙂 : ‏‏لعبة الكلمات المتقاطعة الإصدار 2.accdb

تم فصل هذه المشاركات الى موضوع منفصل ، حتى يتمكن صاحب الموضوع من مواصلة شرحه لعمله ، وارفاق النسخ الاحدث جعفر - فريق العمل ----------------------------------- اداة Activity ToggleButton View 3D IMG 3D Form C4d Animation Close acForm , Me.Form Classic Form مع شرح مختصر بداخل luncher_Form.rar

اسعد الله ايامك ولياليك تمام ولا اجمل .. برنامج احترافي لإعداد وحفظ وطباعة .. الكلمات المتقاطعة ( تعلم بطريقة اللعب والتسلية) جزاك الله خيرا واحسن اليك

السلام عليكم بما ان النموذج فردي single form فالسبب ان النموذج المحذوف مفتوح اذا كان نموذج مستمر فالمفترض بعد الامر requery يختفي السجل المحذوف ولكن في هذه الحاله يجب اغلاق النموذج بعد الحذف او الانتقال لسجل جديد او السجل التالي حسب المفضل لك

بسم الله ماشاء فعلا جراح 😊😊😊

فى قاعده التحقق من الصحة الحقول اللى عايز تعملها اكتب Is Not Null

ممكن من خلال الكود التالي Private Sub btnAdd_Click() Dim db As DAO.Database Dim rs As DAO.Recordset Dim fixedNameValue As String Dim newResultValue As String ' الحصول على القيم من الحقول fixedNameValue = Me.Fixedname newResultValue = Me.Newresult ' التحقق من أن القيم ليست فارغة If IsNull(fixedNameValue) Or IsNull(newResultValue) Then MsgBox "يرجى ملء جميع الحقول قبل الإضافة.", vbExclamation Exit Sub End If ' فتح قاعدة البيانات Set db = CurrentDb ' فتح الجدول المراد الإضافة إليه Set rs = db.OpenRecordset("fixedresult_tbl", dbOpenDynaset) ' إضافة سجل جديد rs.AddNew rs!Fixedname = fixedNameValue rs!Fixedresult = newResultValue rs.Update ' إغلاق مجموعة السجلات rs.Close Set rs = Nothing Set db = Nothing ' إبلاغ المستخدم بالنجاح MsgBox "تمت الإضافة بنجاح!", vbInformation End Sub

هل جربت شيء كهدا If WS.Range("DZ" & j) Like clé or WS.Range("DZ" & j) like "غ" then

دا نورك يا خال انا كان بقالي يجي بتاع ٤ سنين هنا وكنت ناسي الرقم السري ☺️☺️☺️

اليك الحلول التالية يمكنك اختيار ما يناسبك test.xlsx

تفاديا للاخطاء لا تنسى تغديل السطر الخاص بافراغ البيانات السابقة الى f.Range("D11:R" & f.Rows.Count).ClearContents

يسعدنا اننا استطعنا مساعدتك

اخي الكريم المسالة سهلة يكفي تحديد العمود المرغوب نسخ بياناته في السطر الاول مع تحديد خلية بداية اللصق في السطر الثاني ' Sheets("نتيجةت4")اسماء الاعمدة المرغوب ترحيلها OneRng = Array("F13:F" & a, "H13:H" & a, "J13:J" & a, "l13:l" & a, "N13:N" & a, "P13:P" & a, _ "R13:R" & a, "U13:U" & a, "W13:W" & a, "Y13:Y" & a, "AA13:AA" & a, "AC13:AC" & a, "AE13:AE" & a, _ "A13:A" & a) '<=======عمود المسلسل======== ' خلية اللصق Sheets("نتيجة تقييم41") arr = Array("E11", "F11", "G11", "H11", "I11", "J11", "K11", "L11", "M11", "N11", "O11", "P11", "Q11", _ "D11")'<=====اول خلية على عمود تاريخ الميلاد======== تحويل الى كود V3.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا الحل ربما يناسبك Sub CopyRanges() Dim i As Long, a As Long, lr As Long Dim OneRng As Variant, arr As Variant, Irow As Long, C As Long Dim oldData() As Variant, newData() As Variant Dim xlnCalcMethod As XlCalculation Dim WS As Worksheet: Set WS = Sheets("نتيجةت4") Dim f As Worksheet: Set f = Sheets("نتيجة تقييم41") Irow = f.Cells.SpecialCells(xlCellTypeLastCell).Row oldData = Array("غ", "ازرق", "اخضر", "اصفر", "احمر") newData = Array("لم يتقن المعارف", "يفوق التوقعات", "امتلك المعارف والمهارات", "يحتاج لبعض الدعم", "لم يتقن المعارف") a = WS.Columns("E:AE").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row With Application xlnCalcMethod = .Calculation .Calculation = xlCalculationManual .EnableEvents = False .ScreenUpdating = False f.Range("E11:R" & f.Rows.Count).ClearContents OneRng = Array("F13:F" & a, "H13:H" & a, "J13:J" & a, "l13:l" & a, "N13:N" & a, "P13:P" & a, _ "R13:R" & a, "U13:U" & a, "W13:W" & a, "Y13:Y" & a, "AA13:AA" & a, "AC13:AC" & a, "AE13:AE" & a) arr = Array("E11", "F11", "G11", "H11", "I11", "J11", "K11", "L11", "M11", "N11", "O11", "P11", "Q11") For i = 0 To UBound(OneRng) WS.Range(OneRng(i)).Copy f.Range(arr(i)).PasteSpecial xlPasteValues Application.CutCopyMode = False Next lr = f.Columns("E:Q").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set Rng = f.Range("E11:Q" & lr) For C = LBound(oldData) To UBound(oldData) Rng.Replace oldData(C), newData(C), xlWhole, , , , False, False Next With f.Range("R11:R" & lr) .Formula = "=IF(" & WS.Name & "!F13="""",""""," & WS.Name & "!AF13)" .Value = .Value End With .Calculation = xlnCalcMethod .EnableEvents = True .ScreenUpdating = True End With End Sub تحويل الى كود V2.xlsm

لديك اخطاء في تحديد اسماء الخلايا كما في الصورة المرفقة تم تعديل الكود ليسهل التعامل معه Private Sub CommandButton2_Click() 'بحث Dim WS As Worksheet, F As Worksheet Dim Irow As Long, Clé As String, i As Long Set WS = Sheets("Sheet2"): Set F = Sheets("Sheet1"): Clé = F.[E3] Application.ScreenUpdating = False If Clé = Empty Then: MsgBox "برجاء إدخال اسم للبحث عن بياناته", vbCritical, "فلاح": Exit Sub Irow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row Set rng = WS.Range("B3:B" & Irow).Find(Clé, LookIn:=xlValues, _ lookat:=xlWhole, SearchDirection:=xlPrevious) If rng Is Nothing Then: MsgBox " الاسم غير موجود", vbExclamation, Clé: Exit Sub For i = 3 To Irow If WS.Cells(i, 2) = Clé Then ' Colmun (D) F.[D5] = WS.Cells(i, "B") F.[D7] = WS.Cells(i, "C"): F.[D9] = WS.Cells(i, "D"): F.[D11] = WS.Cells(i, "E") F.[D13] = WS.Cells(i, "F"): F.[D15] = WS.Cells(i, "G"): F.[D17] = WS.Cells(i, "H") F.[D19] = WS.Cells(i, "I"): F.[D21] = WS.Cells(i, "J"): F.[D23] = WS.Cells(i, "K") ' Colmun (G) F.[G7] = WS.Cells(i, "L"): F.[G9] = WS.Cells(i, "M"): F.[G11] = WS.Cells(i, "N") F.[G13] = WS.Cells(i, "O"): F.[G15] = WS.Cells(i, "P"): F.[G17] = WS.Cells(i, "Q") F.[G19] = WS.Cells(i, "R"): F.[G21] = WS.Cells(i, "S"): F.[G23] = WS.Cells(i, "T") ' Colmun (J) F.[J7] = WS.Cells(i, "U") F.[J9] = WS.Cells(i, "V"): F.[J11] = WS.Cells(i, "W") F.[J13] = WS.Cells(i, "X"): F.[J15] = WS.Cells(i, "Y") End If Next Application.ScreenUpdating = True End Sub مع تعديل كود الترحيل بالشكل التالي Private Sub CommandButton1_Click() ' اظافة Dim WS As Worksheet: Dim F As Worksheet Set WS = Sheets("Sheet1"): Set F = Sheets("Sheet2") Application.ScreenUpdating = False F.Range("B" & F.Rows.Count).End(xlUp).Offset(1).Resize(, _ 24).Value = Application.Index(WS.Range _ ("D5,D7,D9,D11,D13,D15,D17,D19,D21,D23,G7,G9,G11,G13,G15,G17,G19,G21,G23,J7,J9,J11,J13,J15"), _ 1, 1, Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, _ 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26)) With F.Range("A3:A" & F.Cells(Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-2") End With Lr = F.Range("A65500").End(xlUp).Row b = F.Cells(2, F.Columns.Count).End(xlToLeft).Column F.Range(F.Cells(3, 1), F.Cells(Lr, b)).Borders.Weight = xlThin ' افراغ CommandButton4_Click Application.ScreenUpdating = True MsgBox "تم اضافة البيانات بنجاح" End Sub 123 (1).xlsm

هدا ملف مغاير اخي الكريم على العموم تفضل هده الاكواد الخاصة بك بعد تعديلها Private Sub CommandButton2_Click() 'بحث Dim WS As Worksheet, F As Worksheet, J As Long Dim rng As Range, LastRow As Long, Clé As String Set WS = Sheets("Sheet1"): Set F = Sheets("Sheet2"): Clé = WS.[E3] Application.ScreenUpdating = False If Clé = Empty Then: MsgBox "برجاء إدخال اسم للبحث عن بياناته", vbCritical, "فلاح": Exit Sub LastRow = F.Cells(F.Rows.Count, "B").End(xlUp).Row Set rng = F.Range("B3:B" & LastRow).Find(Clé, LookIn:=xlValues, _ lookat:=xlWhole, SearchDirection:=xlPrevious) If rng Is Nothing Then MsgBox " الاسم غير موجود", vbExclamation, Clé Else J = rng.Row WS.[D5].Value = F.Cells(J, 2).Value: WS.[D7].Value = F.Cells(J, 3).Value WS.[D9].Value = F.Cells(J, 4).Value: WS.[D11].Value = F.Cells(J, 5).Value WS.[D13].Value = F.Cells(J, 6).Value: WS.[D15].Value = F.Cells(J, 7).Value WS.[D17].Value = F.Cells(J, 8).Value: WS.[D19].Value = F.Cells(J, 9).Value WS.[D21].Value = F.Cells(J, 10).Value: WS.[D23].Value = F.Cells(J, 11).Value WS.[G7].Value = F.Cells(J, 12).Value: WS.[G9].Value = F.Cells(J, 13).Value WS.[G11].Value = F.Cells(J, 14).Value: WS.[G13].Value = F.Cells(J, 15).Value WS.[G15].Value = F.Cells(J, 16).Value: WS.[G17].Value = F.Cells(J, 17).Value WS.[G19].Value = F.Cells(J, 18).Value: WS.[G21].Value = F.Cells(J, 19).Value WS.[G23].Value = F.Cells(J, 20).Value Application.ScreenUpdating = True End If End Sub اما بالنسبة لكود التعديل يمكنك اتمامه بنفس الطريقة Private Sub CommandButton5_Click() 'تعديل Dim WS As Worksheet, WS2 As Worksheet Dim LastRow As Long, i As Long Set WS = Sheets("Sheet2"): Set WS2 = Sheets("Sheet1") LastRow = WS.Cells(WS.Rows.Count, 2).End(xlUp).Row For i = 3 To LastRow If WS.Range("B" & i).Value = WS2.[E3] Then WS.Range("B" & i) = WS2.Range("D5") WS.Range("C" & i) = WS2.Range("D7") WS.Range("D" & i) = WS2.Range("D9") WS.Range("E" & i) = WS2.Range("D11") WS.Range("F" & i) = WS2.Range("D13") 'اتمم الكود '''''''''''''''''''' '''''''''''''''''''' MsgBox "تم تعديل البيانات بنجاح" End If Next i Application.ScreenUpdating = True End Sub 123.xlsm

جرب هل هدا ما تقصده Sub TEST() Dim WS As Worksheet: Dim F As Worksheet Set WS = Sheets("ورقة2"): Set F = Sheets("ورقة3") Application.ScreenUpdating = False F.Range("B" & F.Rows.Count).End(xlUp).Offset(1).Resize(, _ 26).Value = Application.Index(WS.Range _ ("D5,C7,C9,C11,D13,E15,D17,D19,D21,J7,J9,J11,J13,J15,J17,I19,K19,J21,O7,O9,O11,N13,N15,N17,O19,O21"), _ 1, 1, Array(2, 3, 1, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, _ 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26)) With F.Range("A4:A" & F.Cells(Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-3") End With Application.ScreenUpdating = True MsgBox "تم ترحيل البيانات بنجاح" End Sub New ورقة عمل Microsoft Excel 2.xlsm

اعتذر لرفع ملف تجريبي . اليك المرفق بعد التجريب . هل اشتغل معك ظهور ملفات PDF من قبل ؟ . اذا كان شغال يبقى المشكله كانت في الترقيم المتكرر . واحنا حليناها . DDAdd&DeletePDF.LAST.rar