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

اذا كنت لاتريد اظهار اليوزرفورم كله لا حاجة لليوزرفورم استعين بورقة لطباعة بيانات محددة من خلال تحديد خلايا محددة ، ثم ما الهدف والفائدة من وراء ذلك؟

السلام عليكم ورحمة الله تعالى وبركاته ..تفضل اخي Dim H, BT(), Rng, Ncol, MH1(), MH2(), MH3 Private Sub UserForm_Initialize() Set H = Sheets("BT") Set Rng = H.Range("A6:H" & H.[A65000].End(xlUp).Row) MH2 = Array(2, 3, 4, 5, 6) MH1 = Array(2, 3, 6, 4, 5) MH3 = 1 BT = Rng.Value Ncol = UBound(MH1) + 1 Me.ListBox1.ColumnWidths = temp & ";150" For i = Ncol + 1 To 5: Me("textbox" & i).Visible = False: Next i Set d = CreateObject("scripting.dictionary") d("*") = "" For i = LBound(BT) To UBound(BT) d(BT(i, MH3)) = "" Next i temp = d.keys Me.ComboBox1.List = temp Me.ComboBox1 = "*" End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub B_résultat_Click() Set MH = Sheets("التصفية") MH.Range("B10:F100").ClearContents A = Me.ListBox1.List MH.[b10].Resize(UBound(A) + 1, UBound(A, 2) + 1) = A With ThisWorkbook.Worksheets("التصفية") Sheet4.Range("c3") = ComboBox1.Text .Range("c5").Value = CDate(Me.TextBox2.Value) .Range("c7").Value = CDate(Me.TextBox3.Value) End With End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub ComboBox1_Change() Sheet3.Range("P2") = ComboBox1.Text TextBox1.Value = Sheets("BT").Range("Q2").Value TextBox2.Value = Sheets("BT").Range("R2").Value TextBox3.Value = Sheets("BT").Range("S2").Value Dim Tbl(): ReDim Tbl(1 To Ncol + 1, 1 To UBound(BT)) ligne = 0 For i = 1 To UBound(BT) If BT(i, MH3) Like Me.ComboBox1 Then ligne = ligne + 1 c = 0 For Each k In MH1 c = c + 1: Tbl(c, ligne) = BT(i, k) Next k ' c = c + 1: Tbl(c, ligne) = i + Decal End If Next i ReDim Preserve Tbl(1 To Ncol + 1, 1 To ligne) Me.ListBox1.Column = Tbl End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Sub TriS(A, gauc, droi) ref = A((gauc + droi) \ 2) g = gauc: d = droi Do Do While A(g) < ref: g = g + 1: Loop Do While ref < A(d): d = d - 1: Loop If g <= d Then temp = A(g): A(g) = A(d): A(d) = temp g = g + 1: d = d - 1 End If Loop While g <= d If g < droi Then Call TriS(A, g, droi) If gauc < d Then Call TriS(A, gauc, d) End Sub Book_MH.xlsm

وهذا ما اريده جزاك الله خيرا على طيب دعائك ولك مثله وزياده وربنا يسعد ايامك وفيك بارك الله اخى والشكر لله ثم لاخواننا واساتذتنا جزاهم الله عنا كل خير اتفضل تعديل بسيط باستخدام الشرط داخل داله اللوب لانى لما عدلت كان الوقت متاخر فعدلت التعديل على السريع Sub Create_Record_For_Every_Item3() ' تكرار السجلات لقاعدة البيانات المقسمة Const RTableName As String = "ItemsCopy_Qr" ' الاستعلام الذي يتم الحاق منه السجلات Const ALLItemsTableName As String = "BarcodeItems_T" ' الجدول الذي الية يتم نسخ السجلات وتكرارها Dim stmailList As String Dim MyDB As Database Dim r As Recordset Dim SqlSt As String Dim ItemCounter As Integer Set MyDB = CurrentDb Set r = MyDB.OpenRecordset(RTableName) DoCmd.SetWarnings False SqlSt = " DELETE " & ALLItemsTableName & ".* FROM " & ALLItemsTableName & " ; " DoCmd.RunSQL (SqlSt) Do If r.Fields("InvoiceNum") = [Forms]![Run]![K1] And r.Fields("sisl") = True Then For ItemCounter = 1 To r.Fields("QuantityS") ' تكرار السجلات حسب الرقم الذي يوجد في الحقل QuantityS SqlSt = "INSERT INTO " & ALLItemsTableName & " (BarCodeNumber,PriceS,ItemName,curName,CuCodn,CodeCounter) VALUES ( """ & r.Fields("BarcodeReader") & """,""" & r.Fields("PriceS") & """,""" & r.Fields("ItemName") & """,""" & r.Fields("currNames") & """,""" & r.Fields("CuCode") & """," & ItemCounter & " );" DoCmd.RunSQL (SqlSt) Next ItemCounter End If r.MoveNext Loop Until r.EOF DoCmd.SetWarnings True If ItemCounter > 0 Then MsgBox "تم ترحيل السجلات بنجاح" Else MsgBox "لا يوجد سجلات لترحيلها" End If r.Close Set r = Nothing Set MyDB = Nothing End Sub مرفق الملف به ملفان واجه كل واحد بتعديل بالتوفيق mm.rar

السلام عليكم ورحمة الله ممكن مساعدة في استعلام يحدد غياب طالب اكثر من مره او مرتين او ثلاثه حسب الطلب واستعلام بين تاريخين ولكم شكري ‏‏الفياب.accdb

Book_MH_3.xlsm

تفضل اخي المسالة ليس لها علاقة بالكود التاريخ يتم احتسابه عن طريق معادلة . Book_MH.xlsm

السلام عليكم أخي أحمد @احمد الفلاحجي ,, اعذرني على تأخر ردي لأنشغالي .. ولأستوجاب عليا الرد لهاذا العمل الكبير والجميل الله الله والابداع .. هنا اقف لك احتراما وتقديرا لهاذا الابداع ولعملك طريقتين لعمل نفس المطلوب في الملف الأخير .. من دون الاولى .. هنا نراء الاحتراف واللعب بالأكواد .. ما شاء الله أخي الغالي أخي أحمد عندما تصفحت الملفين كنت مندهشاً ولساني تلقائياً يدعوا لك في ضهر الغيب ولوالديك ولذريتك لا يحضرني الان الوصف لمشاعري بالسعادة والفرحة الغامرة عند تصفحي الملفين لكن أسأل الله أن يجازيك عني خيرا الجزاء .. وبارك الله على ما قدمته لي من وقتك الثمين والجهد المذهل الذي يدل على احترافك وابداعك فلك مني كل الشكر والتقدير

ياهلا باستاذنا الغالي ابو بسملة لذا في اول مشاركة كتبت وهذا ليس تقليل من العمل ففي جميع الاحوال الاستاذ عمر طاهر يقوم بعمل جيد اسال الله لنا وله التوفيق والسداد تحياتي

اهلا ومرحبا بك اخى واستاذى العزيز وعذرا عالتاخير فالرد صحيح ما ذكرت ولم اطلع عالجدول فى حينه وكان نظرى على الاستعلام احسنت معلمى العزيز عالتوضيح جزاك الله عنا كل خير وفى اعتقادى بانه يحتاج مراجعه الجداول مره اخرى لان عنده جدول company وجدول ras يحتويان ع نفس اسم الشركه يمكن الغاء جدول ras وربط جدول الشركه مباشره مع جدول nas واضافه حقل التاريخ لجدول nas واضافه رمز الشركه فى جدول nas للربط والله اعلى واعلم

Badr Al-Din MiLz فين انت من ده كله .. أين الضغط على الإعجاب 💙 ؟!!!!

مجرد محاولة OfficinaExample(3).xlsx

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

اخي خير اخترها افضل اجابة حتى نعرف انه تم الاجابة على السؤال .....

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

يجب ان تكون متوفر عادة ولكن قم بازالة OLE automation ثم تحديده ثم اغلق الملف بعد حفظه وافتحه من جديد وابحث عن الاداة من داخل محرر الاكواد من قائمة refernce>tools >OLE automation وهذ ا موضوع مشابه كنت قد اجبت عليه احد الاعضاء يمكنك الاطلاع عليه واعلامي ماذا يحدث معك . https://www.officena.net/ib/topic/102575-كود-كليندر-يعمل-على-اوفيس-2003ولايعمل-على2013/#comment-618610 تحياتي .

الكود يعمل فقط على مربع النص الخاص بالتخصص انظر الصورة في الرد السابق لي ..... عموما تفضل ملفك بعد التعديل عليه ........ Database1601.accdb

طيب ادخل على تفصيل النموذج ..... حدث عند الطباعة وادرج الكود التالي .... Dim ctl As Control, strText As Variant, strName As String Me.ScaleMode = 1 For Each ctl In Me.Detail.Controls If ctl.ControlType = acTextBox And ctl.name = "Text4" Then strName = ctl.name If Nz(ctl.Tag, "") = "" Then ctl.Tag = ctl.FontSize End If ctl.FontSize = ctl.Tag Me.FontSize = ctl.FontSize strText = ctl.Value If Len(strText) > 0 Then Do Until TextWidth(strText) < ctl.Width ctl.FontSize = ctl.FontSize - 1 Me.FontSize = ctl.FontSize Loop Do Until TextHeight(strText) < ctl.Height - (ctl.Height * 0.26) ctl.FontSize = ctl.FontSize - 1 Me.FontSize = ctl.FontSize Loop End If End If Next ctl ثم انظر النتيجة ......................

انا مثلك في البداية اتوقعت انا هناك عمليتين لكن لما تدخل جدول nas تجد ان هناك عمليه واحدة مكتمله تابعة للسجل برقم 4 وتاريخ 27 وتفصيلها في الجدول بواقع ثلاث سجلات 1500 وارد لمحمود 200 وارد لخالد باليورو و300 صدار لجابر اما في جدول ras فيوجد سجلين 4 وهو الاب للسجلات الثلاث التي تحدثنا عنها وسجل رقم 5 بتاريخ 24 وليس له سجلات تابعه وبخصوص التكرار الذي اشار اليه الاستاذ الفاضل عمر فهو بسبب اعتماده في عمل الاستعلام all على استعلامين اخرين ولم يتم اضافة حقلي الربط الموجود في الجدولين وهذا تسبب في وجود تكرار غير صحيح وقد تم تعديل مصدر الاستعلام في مشاركتي السابقة واضافة حقل الربط وبالتالي لن يظهر اي سجل غير مكتمل ولم يعد هناك تكرار تحياتي استاذ احمد

وعليكم السلام ورحمه الله وبركاته اتفضل اخى @qathi تم التعديل ان شاء الله يكون ما تريد Set r = MyDB.OpenRecordset("SELECT InvoiceTT.InvoiceNum, InvoiceTT.ItemId, ItemsT.ItemName, ItemsT.BarcodeReader, InvoiceTT.priceu, ItemsT.PriceS, InvoiceTT.QuantityS, InvoiceTT.sisl, tbl_curr.currNames, tbl_curr.CuCode " & _ "FROM (ItemsT INNER JOIN InvoiceTT ON ItemsT.[ItemID] = InvoiceTT.[ItemId]) LEFT JOIN tbl_curr ON InvoiceTT.CuryID = tbl_curr.currID " & _ "WHERE (((InvoiceTT.InvoiceNum)='" & [Forms]![Run]![K1] & "') AND ((InvoiceTT.sisl)=True));") بالتوفيق mm.rar