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

ادن يجب الحصول على ترابط 3 عناصر combobox 10 / 12 / 13 '**** **** A New Addition ************ Private Sub ComboBox10_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) If UCase(a(i, 4)) = UCase(ComboBox12.value) And _ UCase(a(i, 5)) = UCase(ComboBox13.value) Then ' قائمة عمود السعر d(a(i, 10)) = "*": ComboBox10.List = d.keys 'جلب قيمة عمود سعر التجزئة Me.TextBox7.value = a(i, 14) End If Next End Sub '**** Replacing ******** Private Sub ComboBox12_Change() ComboBox13.value = "*" ComboBox10.value = "*" Me.TextBox7.value = "*" End Sub "===Just a possibility=========== 'لجلب السعر 'If Me.ComboBox10.value <> "*" Then _ 'Me.TextBox7.value = Me.ComboBox10.value End Sub اليك الملف بعد اظافة الاكواد بيانات فاتورة2.xlsm

اللهم شفاء لا يغادر سقما وعافية فى النفس والبدن

أرجو إن كان لك اتصال مباشر بالأستاذ فادي أبو وسام، أن تقول له نيابة عني.. لا بأس، طهور إن شاء الله.. اللهم رب الناس أذهب البأس، اشفه وأنت الشافي، لا شفاء إلا شفاؤك، شفاءً لا يغادر سقما.

الكود بطريقة اخرى مع الشرح لتتمكن من تعديله بما يناسبك Public Sub CopyData2() Dim rCrit() As String: ReDim rCrit(1 To 2): Const SrcRow = "EA" Dim x&, i&, Cnt&, arr&, lr&, lastRow&, Cpt As Long Dim Search_Row As Long, Star_Row As Long, Col As Range Dim rngA As Variant, rngB As Variant, OneRng As Range Dim WS As Worksheet: Set WS = Sheets("cheet4") Dim srcWS As Worksheet: Set srcWS = Sheets("شيت الدور الثاني صف رابع ") ' تحديد صف البداية Star_Row = 16: ' عمود الفلترة Search_Row = 131 'تحديد صف وضع البيانات المرحلة Cnt = 10 With Application .ScreenUpdating = False .Calculation = xlManual lastRow = WS.Range(SrcRow & WS.Rows.Count).End(xlUp).Row lr = srcWS.Columns("C:AP").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row 'معايير الفلترة rCrit(1) = "غ": rCrit(2) = "*" & "دور ثان" & "*" 'الاعمدة المرحلة rngA = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, _ 28, 40, 52, 64, 76, 88, 100, 112, 116, Search_Row) 'الاعمدة المرحل اليها rngB = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, _ 15, 18, 21, 24, 27, 30, 33, 36, 39, 42) '("EA")'التحقق من وجود المعايير على عمود arr = Application.Sum _ (Application.IfError(Application.Match(rCrit, WS.Columns(Search_Row), 0), 0)) If arr = 0 Then: MsgBox " المرجوا التحقق من صحة المعايير ", _ vbCritical, "انتباه": Exit Sub 'افراغ البيانات السابقة For x = 0 To UBound(rngB) Set Col = srcWS.Range(srcWS.Cells(Cnt, rngB(x)), srcWS.Cells(lr, rngB(x))) Col.ClearContents Next x With WS If .AutoFilterMode Then .AutoFilterMode = False ' تحديد نطاق البيانات With WS.Range("C15:EA15") .AutoFilter Search_Row - 2, rCrit, xlFilterValues ' نسخ الاعمدة المرئية For i = 0 To UBound(rngA) Set OneRng = WS.Range(WS.Cells(Star_Row, _ rngA(i)), WS.Cells(lastRow, rngA(i))).SpecialCells(xlCellTypeVisible) OneRng.Copy 'لصق البيانات srcWS.Cells(Cnt, rngB(i)).PasteSpecial Paste:=xlPasteValuesAndNumberFormats Next i .AutoFilter End With End With .CutCopyMode = False .Calculation = xlAutomatic .ScreenUpdating = True End With End Sub SAAD V3.xlsm

اللهم اشفه شفاءا عاجلا لا يغادر سقما

اسأل الله العظيم رب العرش العظيم ان يشفيه ويعافيه

أسأل الله العظيم رب العرش العظيم ان يشفيك وان يجمع لك بين الاجر والعافية ألف سلامة عليك أستاذ @Foksh

شفاه الله وجمع له بين الأجر والعافية اخونا عبدالله .. مم يشكو اخونا فادي ؟

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

ربنا يشفيه ويعافيه شفاء لا يغادر سقما

انت هنا حسبت .... اجمالى العدد * 270 ولكن بالنموذج انت كاتب اجمالى العدد * 250 يعني حسبة الاستاذ @kanory مضبوطة .

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

وصلتله كلامك ربنا يكرمك

أسأل الله ان يجمع له بين الاجر والعافية

استاذ محمد أنا مش عارف أقول لحضرتك ايه الله يبارك فيك دنيا وآخرة وجعله في ميزان حسناتك ويعطيك الصحة والعافية أنا درست الكود كويس وجدت حاجة بسيطة غيرتها واشتغل ممتاز غيرت وضع search_row

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

السلام عليكم استاذنا ابو خليل إرهاق وتعب والحمد لله بدأ يتعافى دعواتكم

الشكر لله انا معملتش حاجه

تسلم ايدك يا باشمهندس متشكره جدا لحضرتك 🌷

ولا تزعلى نفسك Dim strSQL1 As String Dim db As DAO.Database Dim codeValue As Variant ' التحقق من أن القائمة ليست فارغة If Me.Resultlist.ListCount = 0 Then MsgBox "لا يوجد عناصر للحذف.", vbExclamation Exit Sub End If ' التحقق من أن هناك عنصر محدد If Me.Resultlist.ListIndex = -1 Then MsgBox "يرجى تحديد عنصر من القائمة للحذف.", vbExclamation Exit Sub End If ' الحصول على القيمة المحددة في ListBox codeValue = Me.Resultlist.Value ' التحقق من أن القيمة ليست Null If IsNull(codeValue) Then MsgBox "يرجى تحديد عنصر من القائمة للحذف.", vbExclamation Exit Sub End If ' إنشاء استعلام SQL لحذف السجل strSQL1 = "DELETE FROM fixedresults_tbl WHERE code = " & codeValue & ";" ' فتح قاعدة البيانات وتنفيذ استعلام الحذف Set db = CurrentDb db.Execute strSQL1, dbFailOnError ' إبلاغ المستخدم بالنجاح MsgBox "تم حذف العنصر بنجاح!", vbInformation ' تحديث ListBox لإزالة العنصر المحذوف Me.Resultlist.Requery ' تحديث الحقل غير المنضم في النموذج الرئيسي إذا كان يحتوي على القيمة المحذوفة If Me.code.Value = codeValue Then Me.code.Value = Null End If ' إغلاق الاتصال بقاعدة البيانات Set db = Nothing

تمام يبقي استخدمي الكود ده Private Sub btnAdd_Click() Dim db As DAO.Database Dim rs As DAO.Recordset Dim fixedNameValue As String Dim newResultValue As String Dim sql As String ' الحصول على القيم من الحقول والتحقق من أنها ليست Null If IsNull(Me.Fixedname) Or IsNull(Me.Newresult) Then MsgBox "يرجى ملء جميع الحقول قبل الإضافة.", vbExclamation Exit Sub End If fixedNameValue = Me.Fixedname.Value newResultValue = Me.Newresult.Value ' التحقق من أن القيم ليست فارغة If fixedNameValue = "" Or newResultValue = "" Then MsgBox "يرجى ملء جميع الحقول قبل الإضافة.", vbExclamation Exit Sub End If ' فتح قاعدة البيانات Set db = CurrentDb ' التحقق من عدم وجود قيمة مكررة لنفس Fixedname و Fixedresult sql = "SELECT COUNT(*) AS RecordCount FROM fixedresult_tbl WHERE Fixedname = '" & fixedNameValue & "' AND Fixedresult = '" & newResultValue & "'" Set rs = db.OpenRecordset(sql) If Not rs.EOF And rs!RecordCount > 0 Then MsgBox "القيمة المدخلة موجودة مسبقًا لنفس الاسم الثابت.", vbExclamation rs.Close Set rs = Nothing Set db = Nothing Exit Sub End If rs.Close Set rs = Nothing ' إنشاء تعليمة SQL لإضافة سجل جديد sql = "INSERT INTO fixedresult_tbl (Fixedname, Fixedresult) " & _ "VALUES ('" & fixedNameValue & "', '" & newResultValue & "')" ' تنفيذ تعليمة SQL db.Execute sql, dbFailOnError ' إغلاق قاعدة البيانات Set db = Nothing ' إبلاغ المستخدم بالنجاح MsgBox "تمت الإضافة بنجاح!", vbInformation End Sub

شكرا جزيلا استاذنا الفاضل kanory واستاذنا الفاضل kkhalifa1960 ربى يزيدكم علما ويبارك لكم فى علمكم النافع لكم كل التحية والاحترام

الف سلامه عليك ربنا بيتمم شفاك على خير 🌷

ممكن دا يتوقف علي اسماء حقولك أو طريقه استخدامك لاكواد أو استعلامات

بعد اذن استاذي @kanory تفضل استاذ @خالد عبد الغفار المرفق حسب طلبك . ووافنا بالرد . khaled-1.rar

هل يتم نسخ البيانات بنفس التنسيق بعد كتابة الكود لاحظت انك واضع تنسيق مخصص على عمود السن في أول أكتوبر 2) هل يتم افراغ جميع الاعمدة قبل كل ترحيل جديد لان الكود السابق يقوم بافراغ الاعمدة من C الى O فقط F.Range("C10:O" & Rows.Count).ClearContents على العموم جرب هدا ووافينا بالنتيجة Option Explicit Public Sub CopyData() '24/06/2024 by:MOHAMEED HICHAM www.officena.net "منتدى الاكسيل" ' Dim rCrit() As String, lastRow As Long Dim Star_Row As Long, Cnt As Long, Cpt As Long Dim C As Long, Search_Row As Long, tmp As Long Dim rngA As Variant, rngB As Variant Dim WS As Worksheet: Set WS = Sheets("cheet4") Dim srcWS As Worksheet: Set srcWS = Sheets("شيت الدور الثاني صف رابع ") Cnt = 10 Star_Row = 16 Search_Row = 131 Application.ScreenUpdating = False rCrit = Split(",لها دور ثان,له دور ثان,غ", ",") lastRow = WS.Cells(WS.Rows.Count, Search_Row).End(xlUp).Row rngA = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, _ 28, 40, 52, 64, 76, 88, 100, 112, 116, 131) rngB = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, _ 15, 18, 21, 24, 27, 30, 33, 36, 39, 42) srcWS.Range("C10:O" & srcWS.Rows.Count).ClearContents For C = Star_Row To lastRow For Cpt = 0 To UBound(rCrit) If WS.Cells(C, _ Search_Row).Value = rCrit(Cpt) Then For tmp = 0 To UBound(rngA) srcWS.Cells(Cnt, rngB(tmp)).Value = WS.Cells(C, rngA(tmp)).Value Next tmp Cnt = Cnt + 1 End If Next Cpt Next C Application.ScreenUpdating = True MsgBox "Done", vbInformation End Sub

قدام حضرتك عندك المثال بتاعك ممكن تحطه وإن شاء الله نحاول نعدلك عليه

اخي بما انك تريد انشاء قاعدة بيانات لتعبئة عناصر اليوزرفورم بشكل ديناميكي ومترابط اسهل طريقة بالنسبة لك هي انشاء جدول على ورقة 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

طيب هل هذه الحسبة مضبوطة .......

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

وعليكم السلام 🙂 يجب إعطاء الامر Me.Requery ومعناها اجلب البيانات الجديدة من مصدر بيانات النموذج (Me معناه انا الكائن الذي تتم العمليه من خلاله ، اي مكان الحدث الذي اتى منه امر الحذف مثلا) ، بعد كل عملية تغيير في الجداول ، سواء حذف بيانات (مثل ما عندك) ، او اضافة او تغيير. وممكن عمل تحديث بيانات نموذج آخر (غير النموذج الذي تم الامر من خلاله) ، فيصبح الامر Forms!frnName.requery جعفر

اولا: . ثم يفتح لك هذا النموذج ، 1. اكتب اسم الحقل (الكلمة التي تريد البحث عنها) الذي تريد ان تبحث عنه في جميع كائنات البرنامج ، حسب ما تم التأشير عليه من جداول واستعلامات وتقارير ونماذج وكود ، 4. انقر البحث ، فيعطيك قائمة بكل كائن فيه هذه الكلمة (تنقر مرتين فيفتح لك الكائن ، وتقدر تغير الكلمة يدويا) ، وبعد ان تطمئن انه لا يوجد خلط وكل شيء واضح ، يمكنك النقر على رقم 2 وتكتب كلمة التغيير/الاستبدال التلقائي لهذه الكلمة في جميع الكائنات.

وعليكم السلام ورحمة الله وبركاته .. 🙂 تفضل .. ستجد طلبك في الاستعلام Last_Mission_Detail_Q مهام الموظفين.accdb

السلام عليكم هذا ايضا بالكود Sub test() Dim r As Integer, rr As Integer For r = 1 To 300 Step 3 rr = rr + 1 Range("A" & r).Resize(3).Value = rr Next r End Sub تحياتي

السلام عليكم بالاضافة الى حل اخي جمال عبد السميع ملك المعادلات هذا حل اخر بواسطة الاكواد Sub test() Dim Sh As Worksheet Dim r As Integer, rr As Integer Set Sh = ThisWorkbook.Worksheets("Sheet1") For r = 1 To 100 Sh.Range("A" & rr + 1) = r Sh.Range("A" & rr + 2) = r Sh.Range("A" & rr + 3) = r rr = rr + 3 Next r End Sub