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

السلام عليكم تكثر الحاجة الى اخراج تقرير حسب حقول محددة يختارها المستخدم وهذا الباب تم التطرق اليه في هذا المنتدى ومن يبحث يجد الكثير .. علما اني قد استفدت واخذت من تلك المواضيع فما انا الا ناقل . ورب ناقل علم الى من هو اعلم منه . وحتى يكون هذا الموضوع مرجع مختصر لكيفية تصميم واعداد التقرير لذا عملت على اعداد مثال صغير وهو عبارة عن جدول ونموذج وتقرير اولا : عمل قائمة في النموذج يتم فيها عرض حقول الجدول عند تحميل النموذج ... وهذه الاكواد هي المسؤولة : 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

وعليكم السلام ورحمة الله تعالى وبركاته تفضل جرب الصيغة التالية =IFERROR(IF(B8<>"";INDEX(price_list!$J$5:$J$10000;MATCH(2;1/(price_list!$E$5:$E$10000=B8)/(price_list!$A$5:$A$10000<=$B$4)));"");"") اخر سعر =INDEX(price_list!$J$5:$J$10000;MATCH(2;1/(price_list!$E$5:$E$10000=B8))) اكبر سعر =MAX(IF(price_list!$A$5:$A$10000<=$B$4;IF(price_list!$E$5:$E$10000=B8;price_list!$J$5:$J$10000))) price list officena - 2.xlsm

وعليكم السلام هذا حل بالمعادلات إن كان يناسبك أخي الكريم كود تجميع .xlsx

السلام عليكم ورحمة الله تعالى وبركاته نظرا للطلب والتساؤلات الكثيرة حول الموضوع او نقاط فرعيه منه قاصدا من ذلك أن يكون الموضوع شاملا ومرجعا للراغبين فى ذلك والدراسبن اليكم بناء القاعدة والذى اتمنى على الله تعالى ان يبدأ البناء وينتهى بشكل احترافى بقدر الإمكان وسوف نبدأ من الصفر تباعا ان شاء الله سوف يتم تحديث الموضوع تباعا الموضوع بأمر الله سوف اضع له الخطوط العريضة طبقا للمؤسسة التى اعمل بها لاننى أصلا سوف اقوم بقاعدة البيانات لمؤسستى وبقدر الإمكان سوف أضع فى الحسبان ان يكون التصميم عام بقدر الإمكان ليتناسب ويتماشى مع الجميع ومع رغباتهم بقدر الإمكان اهلا بكل من يريد المشاركة فى ادراة الموضوع والافكار والتعديل او الاضافة و ...... مبدئيا خلونا نتفق وقتى ضيق فى الفترة المقبلة لما انا مقدم عليه فلذلك ارجو الاعتذار مقدما ان لم التفت الى اى تساؤلات والتى وإن حدث سوف يتم تأجيلها حتى ينتهى مشروع اعداد التطبيق لمؤسستى تماما ان شاء الله بسم الله وعلى بركة الله بداية المشروع اول شئ تصيد وتسجيل الاخطاء بجدول وده وظيفته تسجيل الحطأ باسم الحدث أو الدالة المستخدمة فى الكود عند تنفيذ امر ما ورقم الخطا وصفه للمساعدة مستقبلا فى الوقوف على اماكن الاخطاء لعمل الصيانة اللازمة طبعا تم التطرق اليه فى هذا الموضوع: ويمكنكم الذهاب اليه والمتابعة من هنا طيب حلو جدا جدا وعلشان انا هبدأ بالأكواد ملاحظات هامة جدا جدا جدا جدا لبداية صحيحة واحترافيه : كتابة كود احترافي تتطلب ممارسات جيدة واتباع مبادئ برمجية صحيحة. فيما يلي بعض النصائح التي يمكن أن تساعدك في كتابة كود احترافي: توضيح الكود: استخدم تعليقات لشرح الجزء العلوي من الكود وللأمور المعقدة. اختر أسماء مفيدة وواضحة للمتغيرات والدوال تدل على وظائفها التى تمت كتابتها من اجلها. التنظيم: استخدم الهندسة المعمارية لتنظيم البرنامج إلى وحدات صغيرة وقابلة لإعادة الاستخدام. قم بتقسيم البرنامج إلى وحدات ووظائف مستقلة. الأداء: ابتعد عن الأكواد المكررة وقدّم الأكواد القابلة لإعادة الاستخدام في وحدات. حافظ على الأداء بتجنب العمليات الزائدة غير الضرورية. اختبار الوحدات: قم بكتابة اختبارات للتأكد من أن وحدات الكود الخاصة بك تعمل كما هو متوقع. الأمان: تحقق دائمًا من صحة البيانات الواردة والخارجة من الدوال. تفادى استخدام الأكواد المعرضة لثغرات أمان. تحسين الأداء: استخدم الهندسة العكسية لتحسين الأداء. ابحث عن فرص لتحسين الكفاءة والسرعة. استخدام التعليمات البرمجية النظيفة: ابتعد عن استخدام المتغيرات العالمية عندما لا تكون ضرورية. تجنب الأكواد التي تعتمد على التبديلات الطويلة. توثيق الكود: وفر توثيقًا جيدًا للكود ليسهل على المطورين الآخرين أو نفسك فهم كيف يعمل البرنامج. متابعة المعايير: اتبع معايير البرمجة المتعارف عليها . التحسين المستمر: كن مستعدًا لتحسين الكود الخاص بك بناءً على التعلم وتغييرات متطلبات المشروع. الالتزام بتلك المبادئ يمكن أن يساعدك في كتابة كود أكثر احترافية وقابل للصيانة. حلو الكلام وكل ده هيبان بقدر المستطاع فى التعليمات البرمجية التى سوف تتم تباعا يمكنك استخدام البادئات التالية لتسمية العناصر والكائنات بشكل منظم ويجعل الشيفرة أكثر وضوحًا. البادئات تعتمد على النوع أو الدور الذي تقوم به العناصر: وعلى سبيل المثال وليس الحصر المتغيرات: int للأعداد الصحيحة. dbl للأعداد العشرية. str للنصوص. bool للقيم البولية اى True , False أو Yes , No . Dim intCounter As Integer Dim dblAmount As Double Dim strName As String Dim boolIsValid As Boolean المصفوفات: arr للمصفوفات. Dim arrNames() As String الدوال: Function للدوال التي تعيد قيمة. Sub للإجراءات (دوال بدون إرجاع قيمة). Function CalculateTotal() As Double Sub DisplayMessage() الكائنات: frm للنماذج (Forms). rpt للتقارير (Reports). tbl للجداول (Tables). qry للاستعلامات (Queries). cls للكائنات أو الفئات لتعريف الكلاسات (Classes). bas وحدات الشيفرة- الوحدات النمطية (Modules). tbl للجداول (Tables). qry للاستعلامات (Queries). Dim frmCustomer As Form Dim rptSales As Report Dim tblData As TableDef Dim qryFilteredData As QueryDef الثوابت: c للثوابت. Const cMaxValue As Integer = 100 المتغيرات العامة: g للمتغيرات العامة. Public gCounter As Integer المتغيرات المؤقتة: temp للمتغيرات المؤقتة. Dim tempValue As Integer التعليقات: REM لتعليقات الشيفرة. REM هذا تعليق لشرح الشيفرة الأشكال والعناصر الرسومية: btn للأزرار (Buttons). lbl للتسميات (Labels). txt لحقول النص (Textboxes). chk لمربعات الاختيار (Checkboxes). القوائم والمراقبين: cmb لقائمة الاختيار (Comboboxes). lst لقوائم الاختيار (Listboxes). cb لمراقبات الصندوق (Checkboxes). الكائنات الأخرى: app لكائن التطبيق (Application). cnn لكائن الاتصال (Connection). doc لكائن المستند (Document). الحقول والأعمدة: fld لحقول البيانات (Fields). col لعمود البيانات (Column).

الحمد لله تمام علي ايدك اخي @Foksh

جزانا الله واياكم كل خير.. 🤗 هل تم حل المشكلة أخي العزيز @سامر محمود ؟

اعتقد ان الكود الخاص بي يفعل نفس الشيء ينقصه فقط تحديد النطاق المرغوب الاشتغال عليه لعدم دكرك دالك في اول مشاركة يمكنك التحقق من الرابط التالي : https://streamable.com/49qe96 تم تعديل الكود ليتناسب مع طلبك الاخير Sub Find_and_Replace_values() Dim Title As Variant, WS As Worksheet: Set WS = ActiveSheet Dim arr(2) As Variant, WSrng As Range, i As Integer, Cpt As Long Title = Array("البحث", "الاستبدال") i = 0 Do 'قيمة البحث والاستبدال arr(i) = InputBox(" أدخل قيمة " & " " & Title(i), Title(i)) If StrPtr(arr(i)) = 0 Then Exit Sub If Len(arr(i)) = 0 Then MsgBox "يجب عليك إدخال قيمة" & " " & Title(i), 48, "خطأ" Else i = i + 1 End If Loop Until i > 1 On Error Resume Next ' تحديد النطاق Set WSrng = Application.InputBox(Prompt:=" تحديد نطاق البحث: ", _ Title:="البحث والاستبدال", _ Default:=Selection.Address, Type:=8) If WSrng Is Nothing Then Exit Sub WSrng.Replace arr(0), arr(1), xlPart, , False Cpt = WorksheetFunction.CountIf(WSrng, arr(1)) MsgBox " تم إستبدال " _ & Cpt & " قيمة" _ & vbCrLf & vbCrLf _ & " " & "من" & " " & arr(0) & " " & "إلى" & " " & arr(1), vbInformation, "information" End Sub في حالة الرغبة بعدم استبدال الصيغ بصفة عامة والتعامل مع القيم فقط يمكنك استخدام هدا الخيار ''''''''''''''' ' تحديد النطاق Set WSrng = Application.InputBox(Prompt:=" تحديد نطاق البحث: ", _ Title:="البحث والاستبدال", _ Default:=Selection.Address, Type:=8) If WSrng Is Nothing Then Exit Sub For Each c In WSrng If Not c.HasFormula And c <> "" Then c.Replace arr(0), arr(1), xlPart, , False Cpt = WorksheetFunction.CountIf(WSrng, arr(1)) End If Next c MsgBox " تم إستبدال " _ & Cpt & " قيمة" _ & vbCrLf & vbCrLf _ & " " & "من" & " " & arr(0) & " " & "إلى" & " " & arr(1), vbInformation, "information" End Sub Find_and_Replace_FormulaVersion3.xlsb

العفو اخي يسعدنا اننا استطعنا مساعدتك 😄

وعليكم السلام ورحمة الله تعالى وبركاته Sub test() LastSheet = Sheets.Count Sheets("نمودج").Copy after:=Sheets(LastSheet) End Sub نسخ و اعادة التسمية Sub test2() Dim F As Variant LastSheet = Sheets.Count On Error Resume Next Sheets("نمودج").Copy after:=Sheets(LastSheet) F = InputBox(prompt:="أكتب إسم الورقة الجديد", _ Title:="إعادة تسمية ورقة " & " " & ActiveSheet.Name) ActiveSheet.Name = F End Sub 'قم بتعديله بما يناسبك Sub test3() LastSheet = Sheets.Count On Error Resume Next Sheets("نمودج").Copy after:=Sheets(LastSheet) ActiveSheet.Name = Sheets("TEST").Range("c4").Value End Sub نمودج.xlsb

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

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

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

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

تفضل أخي @سامر محمود . أولا تم اضافة استعلام تحديث بسيط ، وتمت بعض التعديلات . Investi.accdb

خالص الشكر للافاضل Foksh محمد احمد لطفى

طلب اخير ممكن تشيل البروتكشن علشان اسهل لي بالعمل .

اخي @سامر محمود انشىء قاعدة بيانات جديدة وقم باستيراد المكونات الى القاعدة الجديدة ، مع اضافة المكتبات في محرر VBA وإن شاء الله ستعمل معك بشكل طبيعي 😊 متابع معك 😊

ظنك في محله يا صديقي ، ولكن ما رأيك لو جعلنا المجلدات الفرعية التي تريد عرض محتوياتها ان تكون داخل مجلد واحد رئيسي بجانب قاعدة بيانات ؟؟ او حدد لي فكرتك وإن شاء الله بتتنفذ.

تم اعادة ربع الروابط https://drive.google.com/drive/folders/1aUhAmlOINYUNTh5iJ_X2tHMr4rIqf2Qr?usp=drive_link

وعليكم السلام ورحمة الله تعالى وبركاته بعد ادن الاستاد المحترم @محمد حسن المحمد تفضل جرب اخي Sub Total_amount() Dim WS As Worksheet, Dest As Worksheet: Set WS = Sheets("Sheet1"): Set Dest = Sheets("التجميع بدون تكرار") a = WS.Range("B1").CurrentRegion.Value Dim c() ReDim c(1 To UBound(a, 1), 1 To UBound(a, 2)) Cpt = 1 Set mondico = CreateObject("Scripting.Dictionary") Application.ScreenUpdating = False For i = 1 To UBound(a) temp = a(i, 1) & a(i, 2) If Not mondico.exists(temp) Then mondico.Add temp, "" For k = 1 To UBound(a, 2) - 1: c(Cpt, k) = a(i, k): Next k c(Cpt, k) = c(Cpt, k) + a(i, k) Cpt = Cpt + 1 Else j = Application.Match(temp, mondico.keys, 0) col = UBound(a, 2) c(j, col) = c(j, col) + a(i, col) End If Dest.[B1:D1000] = Empty Next Dest.[B1].Resize(mondico.Count, UBound(a, 2)) = c End Sub كود تجميع .xlsb

بما انك لم تقم بارفاق الملف لنتمكن من تحديد النطاق المرغوب نسخه اليك مثال للمطلوب يمكنك تعديله بما يناسبك Sub Copy_My_Data() Dim Cpt&, lCol&, lRow& Dim WSdata As Worksheet, Dest As Worksheet, MyRng As Range, r As String Dim WS1 As Workbook, WS2 As Workbook :Set WS1 = ThisWorkbook With Application .ScreenUpdating = False r = InputBox("قم بإدخال اسم المصنف المرغوب جلب البيانات منه", "Choose file name") On Error Resume Next If r = False And r <> 0 Then Exit Sub If r = 0 Then Set WS2 = Workbooks("transactionTable.xls") 'اول نسخة من المصنف = 0 Else Set WS2 = Workbooks("transactionTable" & " (" & r & ")" & ".xls") ' تعريف المصنف من خلال الرقم End If If Not WS2 Is Nothing Then Set WSdata = WS2.Sheets("Sheet1") ' transactionTable اسم الشيت المنسوخ منه lRow = WSdata.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row lCol = WSdata.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column ' قم بتعديل النطاق المنسوخ بما يناسبك Set MyRng = WSdata. _ Range("A2", WSdata.Cells(lRow, lCol)) Set Dest = WS1.Sheets("Sheet1") ' b2024' اسم شيت اللصق على ملف Cpt = Dest.Cells(Dest.Rows.Count, "A").End(xlUp).Offset(1).Row MyRng.Copy Dest.Range("A" & Cpt).PasteSpecial Paste:=xlPasteValues Application.Goto Dest.[A1], True .CutCopyMode = False .ScreenUpdating = True MsgBox _ "تم نسخ البيانات بنجاح من" & Chr(10) & Chr(10) & WS2.Name, vbInformation Else MsgBox (" لم يتم العثور على المصنف ") & r, 48, "خطأ" On Error GoTo 0 End If End With End Sub بالتوفيق...... test 2.rar

وعليكم السلام ورحمة الله وبركاته تفضل أخي الكريم نسبة الربح وقيمته لكل شخص من مجموع الربح.rar

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي يمكنك اختيار ما يناسبك Sub TEST1() Dim arr(1 To 3) As String ' المسار الافتراضي للمصنف المفتوح arr(1) = ThisWorkbook.path & "\" arr(2) = InputBox("Type in the name of the file you want to open", "Choose file name") arr(3) = Dir(arr(1) & "transactionTable" & " (" & arr(2) & ")" & ".xls*") If arr(3) <> "" Then Set Clé = Workbooks.Open(arr(1) & arr(3)) Else MsgBox ("Workbook Not Found"), vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal End If End Sub '************** ' تنشيط ورقة عمل على نفس المصنف Sub test2() Dim shname As String, x_Name As String Do Until WorksheetExists(x_Name) shname = InputBox("Type in the name of the Sheet you want to Activate") x_Name = "transactionTable" & " (" & shname & ")" If Not WorksheetExists(x_Name) Then MsgBox x_Name & " Doesn't exist!", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal: Exit Sub Loop Sheets(x_Name).Activate End Sub Function WorksheetExists(WSName As String) As Boolean On Error Resume Next WorksheetExists = Worksheets(WSName).Name = WSName On Error GoTo 0 End Function '****************** Sub test3() Dim arr(1 To 3) As String, file_name As String ' قم بتحديد المسار الخاص بك arr(1) = "C:\Users\hicham\OneDrive\Bureau\test" arr(2) = InputBox("Type in the name of the file you want to open", "Choose file name") file_name = "transactionTable" & " (" & arr(2) & ")" arr(3) = arr(1) & "\" & file_name & ".xls" If Dir(arr(3)) = "" Then MsgBox ("Workbook Not Found"), vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal Exit Sub End If Workbooks.Open filename:=arr(3) End Sub '**************************بطرق اخرى ********************* Sub test4() Dim arr(1 To 2) As String, WS As Workbook arr(1) = InputBox("Type in the name of the file you want to open", "Choose file name") arr(2) = ThisWorkbook.path & Application.PathSeparator & "transactionTable" & " (" & arr(1) & ")" & ".xls" If Not Dir(arr(2), vbDirectory) = vbNullString Then Set WS = Workbooks.Open(arr(2)) Else MsgBox arr(2) & Chr(10) & "Workbook Not Found", 48, "Not Found" End If End Sub '***************** Sub test5() Dim arr(1 To 2) As String, WS As Workbook arr(1) = InputBox("Type in the name of the file you want to open", "Choose file name") arr(2) = ThisWorkbook.path & Application.PathSeparator & "transactionTable" & " (" & arr(1) & ")" & ".xls" If Dir(arr(2)) = "" Then MsgBox ("Workbook Not Found"), vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal Exit Sub End If Set WS = Workbooks.Open(arr(2)) End Sub test.rar

وعليكم السلام تفضل: Book1.xlsx