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

السلام عليكم تكثر الحاجة الى اخراج تقرير حسب حقول محددة يختارها المستخدم وهذا الباب تم التطرق اليه في هذا المنتدى ومن يبحث يجد الكثير .. علما اني قد استفدت واخذت من تلك المواضيع فما انا الا ناقل . ورب ناقل علم الى من هو اعلم منه . وحتى يكون هذا الموضوع مرجع مختصر لكيفية تصميم واعداد التقرير لذا عملت على اعداد مثال صغير وهو عبارة عن جدول ونموذج وتقرير اولا : عمل قائمة في النموذج يتم فيها عرض حقول الجدول عند تحميل النموذج ... وهذه الاكواد هي المسؤولة : Private Sub Form_Load() Dim dbs As DAO.Database Dim tbl As DAO.TableDef Dim sCaption As String DoCmd.Restore Set dbs = CurrentDb Set tbl = dbs.TableDefs("table1") For Each fld In tbl.Fields sCaption = "" On Error Resume Next sCaption = fld.Properties("Caption") On Error GoTo 0 lstFields.AddItem fld.Name & ";" & sCaption Next fld Set dbs = Nothing Set tbl = Nothing End Sub ثانيا عملت زر لإعداد الحقول في التقرير ثم فتحه ، وخلف هذا الزر يتم تنفيذ هذه الشفرة Dim i As Integer Dim txt As TextBox Dim lbl As Label Dim intSelectedCount As Integer Dim lngWidth As LoadPictureConstants Dim intSelectedNo As Integer With lstFields If .ItemsSelected.Count = 0 Then MsgBox "يجب اختيار حقل واحد على الأقل", vbExclamation, "خطأ" Exit Sub End If DoCmd.OpenReport "Rep1", acViewDesign, , , acHidden intSelectedCount = .ItemsSelected.Count lngWidth = Reports("Rep1").Width / intSelectedCount Reports("Rep1").Section("PageHeaderSection").Height = 310 Reports!Rep1!Label2.Caption = Nz(Me.Textlabl) Reports("Rep1").Section("Detail").Height = 310 intSelectedNo = 0 For i = 0 To .ListCount - 1 If .Selected(i) Then Set lbl = CreateReportControl("Rep1", acLabel, acPageHeader, , , intSelectedNo * (lngWidth + 50), 5, lngWidth, 300) lbl.Caption = .Column(1, i) lbl.BackStyle = 1 lbl.BackColor = RGB(200, 200, 200) lbl.BorderStyle = 1 lbl.FontBold = True lbl.TextAlign = 2 Set txt = CreateReportControl("Rep1", acTextBox, acDetail, , .Column(0, i), intSelectedNo * (lngWidth + 50), 5, lngWidth, 300) txt.BorderStyle = 1 txt.TextAlign = 2 intSelectedNo = intSelectedNo + 1 End If Next i End With DoCmd.OpenReport "Rep1", acViewReport ملحوظات : جعلت زر الخروج في التقرير يغلق التقرير ( من غير حفظ ) متجاوزا رسالة تأكيد الحفظ حفظ التقرير يسبب تراكم الحقول المصنوعة داخل الكود .. ومن ثم تظهر المشكلات والأخطاء ختاما لا تنسوني من دعواتكم الصالحة واتمنى ان تجدوا فيه الفائدة والمتعة اختيار حقول التقرير.rar

تفضل صديقي تجربة - Copy.accdb

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

حبيبنا @Foksh أقترح عليك أن تضع آخر نسخة بالتحديثات وسنقوم بتحديثها في المشاركة الأولى .. وذلك لتسهيل العمل على المستفيدين والمتعلمين أمثالنا

Fokshاجابتك ضبطت معي وشكرا لكم انت والاخ kanory والله انه حظي الوافر الي تقابلوا عمالقة البرمجة معي اليوم

شكرا استاذنا الفاضل وجزاك الله خيرا

طيب أنظر إلى هذه الفكرة :

السلام عليكم ورحمة الله وبركاته في ملاحظة جانبية سأتطرق إليها للتوضيح في نقطة قد يتساءل البعض عنها في هذا الجزء For i = 0 To UBound(arLabels) UpdateLabel frm, "Label" & CStr(i + 1), arLabels(i), enLabels(i) UpdateLabel frm, "Command" & CStr(i + 1), arLabels(i), enLabels(i) Next i End Sub تمت إضافة هذا الجزء من الكود ليشمل الـ Lable كما في الجزء الأول ، والـ Command في الجزء الثاني. حيث أن المسميات ستكون متبوعة برقم وهو الذي سيحدد رقم السطر في ملفات اللغة ( Arabic , English ) ، فهنا نستطيع التوحيد في مسميات البرنامج ( كتوحيد المقامات في الرياضيات 😅 ) طبعاً هنا سنحتاج جزء واحد من السطر ، ولنفترض أن الكود سيصبح بهذا الشكل:- For i = 0 To UBound(arLabels) UpdateLabel frm, "Officna" & CStr(i + 1), arLabels(i), enLabels(i) Next i End Sub هنا قمت بتوحيد جميع العناصر والكائنات في المشروع ( مربعات نص ، ليبلات ، ازرار ..... إلخ ) تحت اسم Officna وهنا يسهل علينا - وكما ذكر معلمنا الفاضل @ابوخليل - حفظ المسميات وسهولة الوصول إليها وتحديدها .. ودمتم بخير 🤗

تفضل اخي حاولت قدر الامكان اختصار الكود بطريقة ابسط نوعا ما ليسهل التعامل معه والتعديل عليه للضرورة مع توضيح بعض النقاط المهمة Sub GetPrice3() Dim WSitems As Worksheet, WSPrice As Worksheet, dest As Worksheet, ws As Worksheet Dim s As Range, Title As Range, r As Range, Rng As Range, ShtDate As Date, MaxDate As Date Dim c As Range, f As Range, a&, XPric As String, Clé As Range Set WSitems = ThisWorkbook.Sheets("items") Set dest = Worksheets("itemout") 'B4 'استخراج اسم قائمة الاسعار بشرط التاريخ المدخل في الخلية XPric = dest.Range("E4"): Set Title = dest.[B8:B32] If Len(dest.Range("B4").Value) = 0 Then: MsgBox "يجب عليك إدخال التاريخ", vbExclamation: Exit Sub If IsDate(dest.Range("B4").Value) Then For Each ws In Worksheets If IsDate(ws.Name) Then ShtDate = CDate(ws.Name) If ShtDate <= dest.Range("B4").Value And ShtDate > MaxDate Then MaxDate = ShtDate End If Next ws If MaxDate = 0 Then MsgBox "قائمة الأسعار " & dest & _ vbCrLf & vbCrLf & "غير موجودة", _ vbInformation, "التحقق من قوائم الأسعار" Else 'تعريف الورقة الهدف Set WSPrice = Sheets(Format(MaxDate, "dd-m-yyyy")) End If End If 'التحقق من ادخال كود الصتف If Application.WorksheetFunction.CountA(dest.Range("B8:B32")) = 0 Then MsgBox "المرجوا ادخال كود الصنف", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "Admin" Exit Sub End If With Application .EnableEvents = False .ScreenUpdating = False If WSPrice.FilterMode Then WSPrice.ShowAllData ' البحث عن عمود نوع التعامل Set Clé = WSPrice.Rows(3).Find(What:=XPric, LookIn:=xlValues, _ LookAt:=xlWhole) If Not Clé Is Nothing Then ' افراغ البيانات السابقة For a = 8 To 32 Union(dest.Range("A" & a), dest.Range("C" & a), dest.Range("G" & a & ":H" & a)).ClearContents Next a '******** ' جلب البيانات من القائمة************* ' بشرط كود الصنف عمود 'B' For Each r In dest.Range("B8", dest.Cells(Rows.Count, 2).End(xlUp)) 'D' البحث في قائمة الاسعار عمود Set Rng = WSPrice.Range("D:D").Find(r.Value, , xlValues, xlWhole) If Not Rng Is Nothing Then '7(G)' وضع السعر في عمود dest.Cells(r.Row, 7).Value = WSPrice.Cells(Rng.Row, Clé.Column).Value ' تحديد عود السعر بشرط الخلية 'E4 For Key = 8 To dest.Range("B" & Rows.Count).End(xlUp).Row 'items'جلب اسم الصنف من ورقة Set Col = WSitems.Cells.Find(What:=dest.Range("B" & Key), LookAt:=xlPart) If Not Col Is Nothing And Col <> "" Then dest.Range("C" & Key) = Col.Offset(0, 1).Value Next Key End If Next ' تسلسل عمود 'A' For Each s In Title If s.Value <> "" Then J = J + 1: s.Offset(0, -1).Value = Format(J, "0") Next fRng = dest.Range("B" & dest.Rows.Count).End(xlUp).Row 'القيمة F*G With dest.Range("H8:H" & fRng) .Formula = "=IF(F8<>"""",F8*G8,"""")" .Value = .Value End With ' نسخ اسم قائمة السعر المستخدمة dest.[i1] = "اسعار قائمة" & ":" & WSPrice.Name Else MsgBox "نوع التعامل غير موجود" & _ vbCrLf & "", vbExclamation, XPric End If .EnableEvents = True .ScreenUpdating = True End With End Sub وكما سبق الذكر سابقا عند نسخك للكود على ملفك الاصلي تأكد من تطابق بيانات الخلية E4 مع رؤؤوس الأعمدة في أوراق قوائم الأسعار اليك الملف للتجربة price list officena V4.xlsm

برنامج "Access Runtime" هو نسخة من Microsoft Access تم تصميمها لتشغيل تطبيقات قواعد البيانات التي تم إنشاؤها باستخدام Microsoft Access بدون الحاجة إلى وجود نسخة كاملة من Microsoft Office على الكمبيوتر الذي يقوم بتشغيل التطبيق. فهو يمكّنك من تشغيل مشاريع Access دون الحاجة إلى تثبيت نسخة كاملة من Microsoft Office على جهاز الكمبيوتر . ويعتبر هذا خياراً مفيداً إذا كنت ترغب في توزيع تطبيق Access لمستخدمين لا يحتاجون إلى تحرير التصميم أو الإنشاء. ومع ذلك، يجب أن تكون النسخة من "Access Runtime" متوافقة مع إصدار الـ Access الذي تم إنشاء التطبيق به. بمعنى آخر، إذا كانت قاعدة البيانات الخاصة بك تم إنشاؤها باستخدام Access 2016، عليك استخدام Access Runtime 2016 أو إصدار أحدث لتشغيل التطبيق. وبالطبع يُذكر أن "Access Runtime" تُستخدم فقط لتشغيل التطبيقات ولا توفر إمكانيات التصميم أو التحرير

محاولتي: التنسيق الشرطي_01.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا الحل بالاكواد هل يناسبك Public Property Get ws() As Worksheet: Set ws = Sheet1 End Property Private Sub ComboBox1_GotFocus() Application.ScreenUpdating = False Set d = CreateObject("Scripting.Dictionary") For Each c In ws.Range("O2", ws.Cells(Rows.Count, "O").End(xlUp)) If Not d.Exists(c.Value) Then d(c.Value) = "" Next c MyRng = d.keys Me.ComboBox1.List = MyRng End Sub '******************* Private Sub ComboBox1_Change() Dim i&, lastrow&, r As Range, MyRng As Range lastrow = ws.Columns("A:O").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set MyRng = ws.Range("A2:O" & lastrow - 1): Set Tbl = ws.ListObjects("الجدول93") Clé = ComboBox1 Application.ScreenUpdating = False Tbl.Range.AutoFilter Field:=15, Criteria1:=Clé For i = 2 To lastrow Step 2 Set r = Range("A" & i & ":O" & i) If Cells(i, "O").Value = "الورشة" Then r.Interior.Color = RGB(51, 204, 204) ElseIf Cells(i, "O").Value = "التقنية" Then r.Interior.Color = RGB(255, 204, 153) ElseIf Cells(i, "O").Value = "التأجير" Then r.Interior.Color = RGB(255, 255, 0) Else r.Interior.ColorIndex = xlColorIndexNone End If Next i If Me.ComboBox1 = Empty Then Tbl.ShowAutoFilter = False: MyRng.Interior.ColorIndex = xlColorIndexNone Application.ScreenUpdating = True End Sub نموذج3 .xlsb

وعليكم السلام ورحمة الله وبركاته اتفضل جرب odbda.accdb