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

وعليكم السلام تفضل تضليل أيام الجمعة والسبت من كل شهر.xlsm

اتفضل اخى خيرى الملف بعد التعديل عل المعادلة تضليل أيام الجمعة والسبت من كل شهر.xlsm

السلام عليكم 🙂 اخي @essam rabea كنت خبير ، والآن اهلا وسهلا بك خبيرا معتمدا بيننا 🙂 جعفر

Expand And Collapse( الطى والتوسيع ) ExpandCollapse( الطى والتوسيع).mdb

السلام عليكم تم التعديل على المعادلات في العمودين E و F... جرب المرفق لعل فيه ما تريد... بن علية حاجي توزيع نقود كما بالبنوك (1).rar

تم التعديل كما تريد Option Explicit Sub get_data() Application.ScreenUpdating = False Dim dic As Object Set dic = CreateObject("scripting.dictionary") Dim dic_key Dim ro# Dim i%: i = 2 Dim x_titel#: x_titel = 2 Dim find_ro# Dim lrDem# lrDem = Demandes.Cells(Rows.Count, 1).End(3).Row Dim my_rg As Range Set my_rg = Demandes.Range("A1:F" & lrDem) On Error Resume Next Demandes.ShowAllData On Error GoTo 0 Facteur.Range("H:M").Clear lrDem = Demandes.Cells(Rows.Count, 1).End(3).Row Facteur.Range("Q1") = "رقم الفاتورة" With dic Do Until Demandes.Cells(i, 1) = vbNullString If Not .exists(Demandes.Cells(i, 1).Value) Then .Add Demandes.Cells(i, 1).Value, "" End If i = i + 1 Loop For Each dic_key In dic.keys Facteur.Range("H" & x_titel).Resize(8, 2) = _ Range("Header_Rg").Value Range("H" & x_titel + 2).NumberFormat = "0" Facteur.Range("Q2") = dic_key my_rg.AdvancedFilter 1, Facteur.Range("Q1:Q2") Demandes.Range("c1:f" & lrDem). _ SpecialCells(xlCellTypeVisible).Copy _ Facteur.Range("H" & x_titel + 9) Application.CutCopyMode = False Demandes.ShowAllData find_ro = Demandes.Range("A1:A" & lrDem).Find(dic_key).Row With Range("H" & x_titel + 6) .Value = Demandes.Cells(find_ro, 2) .NumberFormat = "d/m/YYY" .Offset(-2, 1) = dic_key End With ro = Facteur.Cells(Rows.Count, "H").End(3).Row Range("K" & ro + 2) = _ Evaluate("SUM(K" & x_titel + 10 & ":K" & ro & ")") Range("H" & ro + 2).Resize(3) = _ Range("RESULT").Value Range("K" & ro + 3) = _ Range("K" & ro + 2) * [D2] / 100 Range("K" & ro + 4) = _ Range("K" & ro + 2) + Range("K" & ro + 3) x_titel = ro + 8 Next dic_key .RemoveAll End With Set my_rg = Nothing Range("Q1:Q2").Clear Columns("H:M").InsertIndent 1 Application.ScreenUpdating = True End Sub '========================= Sub clear_data() Facteur.Range("H:K").Clear End Sub '========================= Sub Print_areas() Application.ScreenUpdating = False Dim My_Area As Range Dim last_row# Dim Serach_RG As Range Dim find_what$: find_what = "الإجمالي شامل الضريبة" Dim My_row#, Fix_row# Facteur.ResetAllPageBreaks last_row = Facteur.Cells(Rows.Count, "H").End(3).Row If last_row = 1 Then GoTo Leave_Me_Alone Set My_Area = Range("H1:K" & last_row) Facteur.PageSetup.PrintArea = My_Area.Address Set Serach_RG = My_Area.Find(find_what, after:=Range("h2")) If Not Serach_RG Is Nothing Then My_row = Serach_RG.Row: Fix_row = My_row Do Facteur.HPageBreaks.Add Before:=Range("H" & My_row + 3) Set Serach_RG = My_Area.FindNext(Serach_RG) My_row = Serach_RG.Row If My_row = Fix_row Then Exit Do Loop End If Leave_Me_Alone: Application.ScreenUpdating = True End Sub '''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Worksheet_Activate() ' Dim t%, h%, w%, l% ' h = 40: w = 140: l = 758 ' With Me.Shapes.Range(Array("Button 1")) ' .Height = h: .Width = w ' .Left = l: .Top = 10 ' End With ' With Me.Shapes.Range(Array("Button 2")) ' .Height = h: .Width = w ' .Left = l: .Top = 60 ' End With ' With Me.Shapes.Range(Array("Button 3")) ' .Height = h: .Width = w ' .Left = l: .Top = 110 ' End With ' End Sub ' '''''''''''''''''''''''''''''''''''''''''''''''' الملف مرفق Tasmim Fatura_with Printing_Special.xlsm

السلام عليكم هذا تعدل على الكود mmmmmmmmmta3rif_cod بإستخدام النسخ واللصق ان شاء الله يفي بالغرض Sub mmmmmmmmmta3rif_cod() ' مربوط بالفيلكوأب الي في سطر 9 في صفحة استعلام المبيعات Application.ScreenUpdating = False ' للتسريع Application.EnableEvents = False ' للتسريع Application.Calculation = xlCalculationManual ' للتسريع Sheets("استعلام_المبيعات").Unprotect "" ' فك الحماية Sheets("المبيعات").Unprotect "" ' فك الحماية Dim Sh As Worksheet Dim Sh1 As Worksheet Dim Mx, i, Rr, Z, ii Dim Nu, Cu, r_o, r, Lr Dim Rn As Range Set Sh = Sheets("المبيعات"): Set Sh1 = Sheets("استعلام_المبيعات") Mx = Application.WorksheetFunction.CountA([I11:I5000]) Nu = Sh1.[i11] If Mx = 0 Then Exit Sub If Sh1.[i2] = "" Then MsgBox "حقل رقم الفاتورة فارغ !!", vbExclamation, "تنبية !!!": Exit Sub Lr = Sh.Cells(Sh.Rows.Count, "I").End(xlUp).Row For i = 2 To Lr r = Sh.Cells(i, "i") If r = Nu Then ii = ii + 1 If ii = 1 Then r_o = Sh.Cells(i, "i").Row Cu = Application.CountIf(Sh.Range("I2:I" & Lr), Nu) If Cu = Mx Then Sh1.Range("A11:J" & Sh1.Cells(Sh1.Rows.Count, "I").End(xlUp).Row).Copy Sh.Range("A" & r_o).PasteSpecial xlPasteValues Application.CutCopyMode = False Exit For Else For Rr = r_o To r_o + Cu If Rn Is Nothing Then Set Rn = Sh.Range("A" & Rr) Else Set Rn = Union(Rn, Sh.Range("A" & Rr)) End If Next Rr Lr = Sh1.Cells(Sh1.Rows.Count, "I").End(xlUp).Row If Mx > Cu Then Rn.EntireRow.Delete Z = Mx - Cu Sh.Rows(r_o & ":" & r_o + Z).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Sh1.Range("A11:J" & Lr).Copy Sh.Range("A" & r_o).PasteSpecial xlPasteValues: Application.CutCopyMode = False Exit For Else Rn.EntireRow.Delete Z = Cu - Mx Sh.Rows(r_o & ":" & r_o + Z).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Sh1.Range("A11:J" & Lr).Copy Sh.Range("A" & r_o).PasteSpecial xlPasteValues: Application.CutCopyMode = False Exit For End If End If End If Next i Application.ScreenUpdating = True ' للتسريع Application.EnableEvents = True ' للتسريع Application.Calculation = xlCalculationAutomatic ' للتسريع End Sub وان لديك استفسارات اطرحها ولن يقصر معك الجميع تحياتي

تم تحسين العمل كي تتم طباعة كل فاتورة على ورقة منفردة (حسب الاختيار بالضغط على زر تجهيز للطباعة في المرفق) Option Explicit Sub get_data() Application.ScreenUpdating = False Dim dic As Object Dim dic_key Dim ro# Dim i%: i = 2 Dim x_titel#: x_titel = 2 Dim lrDem# Facteur.Range("H:M").Clear lrDem = Demandes.Cells(Rows.Count, 1).End(3).Row Facteur.Range("Q1") = "رقم الفاتورة" Dim my_rg As Range Set my_rg = Demandes.Range("a1:f" & lrDem) Set dic = CreateObject("scripting.dictionary") With dic Do Until Demandes.Cells(i, 1) = vbNullString If Not .exists(Demandes.Cells(i, 1).Value) Then .Add Demandes.Cells(i, 1).Value, "" End If i = i + 1 Loop For Each dic_key In dic.keys Facteur.Range("H" & x_titel).Resize(8, 2).Value = Range("Header_Rg").Value Range("H" & x_titel + 2).NumberFormat = "0" Facteur.Range("Q2") = dic_key my_rg.AdvancedFilter 2, Facteur.Range("Q1:Q2"), Facteur.Range("H" & x_titel + 9) Range("I" & x_titel + 5) = Range("i" & x_titel + 10) Range("I" & x_titel + 5).NumberFormat = "d/m/YYY" Range("I" & x_titel + 4) = dic_key ro = Facteur.Cells(Rows.Count, "H").End(3).Row Range("M" & ro + 2) = Evaluate("SUM(M" & x_titel + 10 & ":M" & ro & ")") Range("M" & ro + 3).Value = Range("M" & ro + 2) * [D2] / 100 Range("M" & ro + 4).Value = Range("M" & ro + 2) + Range("M" & ro + 3) Range("H" & ro + 2).Resize(3).Value = Range("RESULT").Value x_titel = ro + 8 Next End With dic.RemoveAll: Set my_rg = Nothing Range("Q1:Q2").Clear Columns("H:M").InsertIndent 1 Application.ScreenUpdating = True End Sub '========================= Sub clear_data() Facteur.Range("H:M").Clear End Sub '========================= Sub Print_areas() Application.ScreenUpdating = False Dim My_Area As Range Dim last_row# Dim Serach_RG As Range Dim find_what$: find_what = "الإجمالي شامل الضريبة" Dim My_row#, Fix_row# Facteur.ResetAllPageBreaks last_row = Facteur.Cells(Rows.Count, "H").End(3).Row If last_row = 1 Then GoTo Leave_Me_Alone Set My_Area = Range("H1:M" & last_row) Facteur.PageSetup.PrintArea = My_Area.Address Set Serach_RG = My_Area.Find(find_what, after:=Range("h2")) If Not Serach_RG Is Nothing Then My_row = Serach_RG.Row: Fix_row = My_row Do Facteur.HPageBreaks.Add Before:=Range("H" & My_row + 3) Set Serach_RG = My_Area.FindNext(Serach_RG) My_row = Serach_RG.Row If My_row = Fix_row Then Exit Do Loop End If Leave_Me_Alone: Application.ScreenUpdating = True End Sub الملف الجديد مرفق Tasmim Fatura_with Printing.xlsm

السلام عليكم, في السابق كنت استخدم خطوط معينة في برامجي وعند اعطاء البرنامج للعميل لاتظهر الخطوط التي قمت باستخدامها بل يظهر بمكانها الخط ( Arial ) وهذه مُشكلة. كت في وقتها الجأ الى ان اضع الخط بجانب قاعدة البيانات وفي داخل قاعدة البيانات اقوم بعمل تحقق لمجلد Fonts والبحث عن الخط في بداية تشغيل القاعدة, فإن لم يجده يعي رسالة للعميل بان الط مفقود وعليه ان يقوم بتثبيته من جانب البرنامج. بحثت طويلاً في الانترنت عن تثبيت خط من الاكسس فقط بدون مساعدة عامل خارجي ولكن لم اصل لنتيجة. اليوم بحمد الله قمت بحل المشكلة بإستخدام ( Visual .NET ) قمت بكتابة اداة بسيطة وظيفتها تثبيت الخط. يتم تمرير براميتر لها وهي بدورها ستقوم بتثبيته الدوال المستخدمة: AddFontResource CreateScalableFontResource ShellExecuteA للمزيد من المعلومات ، اضغط على اسم الدالة ارفقت لكم المصادر من MSDN شرح بسيط لمن لم يعرف ماذا اقصد بتثبيت الخط واستخدام الخط وانه لن يظهر في حال كان العميل لا يملكه. قمت بارفاق قاعدة بيانات لكم كـ مثال للشرح مع الخط المستخدم مع الاداة. شرح الاستعمال: يجب ان تكون الاداة ( SEMO_RegisterFont.exe ) هي والخط الذي سوف تستخدمه بجانب قاعدة البيانات. افتح برنامجك وضع فيه هذا الاجراء. Sub RegisterFont(nFont) Dim strExe As String Dim strArg As String strExe = CurrentProject.Path & "\" & "SEMO_RegisterFont.exe" strArg = "/SEMO/" & nFont ShellExecute 0, "runas", strExe, strArg, vbNullString, SW_SHOWNORMAL End Sub في الاستدعاء اي في الحدث Form_Current RegisterFont "DroidSansArabic.ttf" حيث ان الـ DroidSansArabic.ttf هو اسم الخط الذي قمنا بوضعه بجانب قاعدة البيانات ملاحظة مهمة جدا: في حال كان اسم الخط يتكون من اكثر من كلمة مثل ( Droid Sans Arabic.ttf ) قم بحذف المسافات بين كلمة واخرى بحيث يصبح ( DroidSansArabic.tts ) وستعمل قاعدة البيانات التي قمت بتصميمها بشكل رائع وبالخطوط التي قمت انت بأختيارها بدون الخوف من مشكلة عدم توفر الخطوط في جهاز العميل. الشرح حصري للمنتدى وغير موجود في الانترنت. لا تشكرني الا اذا وجدت انني استحق ذلك. تم بحمد الله حسنين RegisterFont_SEMO_Pa3x.rar

السادة المشرفون الاخوة الاعضاء السلام عليكم لدي جدول درجات طلاب ((ارفقت نسخة منه ))اضافة القرار.rarولكل طالب اربع مواد دراسية وكل مادة مكونه من درجة سعي من 50 ودرجة امتحان نهاءي من 50 تجمع هاتان الدرجتان لتصبح الدرجة من 100 وهي الدرجة النهائية ما اتمناه عليكم هو لدينا درجة تسمى درجة القرار (كيرف لرفع الدرجات النهائية ارلقريبة من 50) ولكل طالب 10 درجات قرار والية اضافتها على النحو التالي:: تعطى للدرجة الأقرب من 50 فمثلا لو كانت لدى الطالب درجتان الأولى 46 والثانية 43 فان الدرجة التي تستفيد من القرار هي 46 ويكون مقدار الدرجات المضافة 4 درجات والمتبقي 6 درجات ولو كانت لدية مادة اخرى درجته النهائية فيها 45 فيمكن له الاستفادة من الدرجات ال 6 المتبقية وياخذ منها 5 درجات تضاف الى الدرجة 45 لتصبح 50 ويكون المتبقي له درجة واحدة اما اذا كان للطالب درجتين كل منهما 40 فلمن تضاف الردات العر الجواب تضاف الى المادة ذات السعي الاقل ارجو المساعدة في ذلك جزيتم خيرا وان كانت الألية غير واضحة ارجو ابلاغي لاعيد توضيحها اكثر

أرفق اليكم نموذج بحث متعدد النتائج .. به وحدة نمطية بسيطة لتوحديد الأحرف المتشابهة وإزالة المسافات وتجاهل الهمزات والتشكيل ..عسى يجد من ينتفع به.وتجدر الإشارة أن أغلبه من أفكار رواد هذا المنتدى العزيز. أعزكم الله .. تحياتى Officna.rar

هل يمكن تطبيق التشفير المستخدم هنا على هذا المرفق اريد تشفير جميع حقول الجدول tbllvlUsers ما عدا الحقلين (UserID , lvlGroupID) على ان يتم اظهار كل البيانات بدون تشفير فى النموذج frmlvlAuthorize او اى نموذج اخر كما فى المرفق الحالى http://www.mediafire.com/file/ioxj1m5onagfao3/SecurityLevel+group.accdb  جزاكم الله خيرا SecurityLevel group.accdb

مبارك أخوي عصام عملك الأخير في البحث المتعدد ينم عن خبرة تستحق عن جدارة هذه الترقية نتمني لك مزيد من التقدم والارتقاء

مبارك عليك أخي @essam rabea جعلك الله منمن ينتفع به علمة .. وذخراً للأسلام والمسلمين .. سعدنا بهذا الخبر الجميل من أستاذنا الكبير @jjafferr

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

أخي @essam rabea اسأل الله أن ينفع بك وبعلمك ......

ألف . ألف . مبروك أخي @essam rabea تستاهل اللقب وبجدارة .....

السلام عليكم اضافة الى حل الاخ مصطفى شرف كود ان شاء الله يفي بالغرض ' اعمدة الجمع من عمود Private Const On_C As Integer = 4 ' الى عمود Private Const End_C As Integer = 7 ' مسمى عمود التكرار Private Const Colum = "C" Sub Ali_Def() Dim Lr As Long, Rw As Long Dim Col As Long Dim DelRNG As Range Application.ScreenUpdating = False Lr = Range(Colum & Rows.Count).End(xlUp).Row Set DelRNG = Range(Colum & Lr + 10) For Rw = 2 To Lr If Application.WorksheetFunction.CountIf(Range(Colum & 2 & ":" & Colum & Rw), _ Range(Colum & Rw)) > 1 Then Set DelRNG = Union(DelRNG, Range(Colum & Rw)) Else ' For Col = On_C To End_C Cells(Rw, Col) = Application.WorksheetFunction.SumIf(Range(Colum & ":" & Colum), Range(Colum & Rw), Columns(Col)) Next Col End If Next Rw DelRNG.EntireRow.Delete xlShiftUp Set DelRNG = Nothing Application.ScreenUpdating = True End Sub

هذا السطر معناه اكتب لي قيمة متغير mySQL في النافذة تحت الكود ، وجميل لما نمشي مع الكود سطر بسطر ، بحيث الكود يخبرنا بقيم المتغيرات ، اثناؤ عمل الكود : جعفر

قصدك بطريقتي في تفكيك اسطر الكود وتبسيطها الى اسطر ، لأن الكود هذا مو خط يدي 🙂 الجزء الاول من كودك ناقص ، وبعد التعديل ، ويجب ان يكون هكذا: Private Sub CreatAdmin() mySQL = "INSERT INTO tbllvlUsers" mySQL = mySQL & "( UserID," '1 UserID mySQL = mySQL & "lvlGroupID," '2 GroupID mySQL = mySQL & "UName," '3 UserName mySQL = mySQL & "Password," '4 Password mySQL = mySQL & "Fname," '5 FullName mySQL = mySQL & "lvlQ ," '6 Questions mySQL = mySQL & "lvlAnsr," '7 Answers mySQL = mySQL & "Umail )" '8 EmailUsers 'Debug.Print mySQL mySQL = mySQL & " SELECT " mySQL = mySQL & " '1' AS UserID," '1 UserID mySQL = mySQL & " '2' AS lvlGroupID," '2 GroupID mySQL = mySQL & " Encrypt(KeyEnde(),'admin') AS UName," '3 UserName mySQL = mySQL & " Encrypt(KeyEnde(),'admin') AS Password," '4 Password mySQL = mySQL & " Encrypt(KeyEnde(),'admin') AS Fname," '5 FullName mySQL = mySQL & " Encrypt(KeyEnde(),'admin') AS lvlQ," '6 Questions mySQL = mySQL & " Encrypt(KeyEnde(),'admin') AS lvlAnsr," '7 Answers mySQL = mySQL & " Encrypt(KeyEnde(),'admin@admin.com') AS Umail;" '8 EmailUsers 'Debug.Print mySQL DoCmd.SetWarnings False DoCmd.RunSQL mySQL DoCmd.SetWarnings True MsgBox "تم إنشاء المستخدم المسئول عن قاعدة البيانات" & vbCrLf & _ "اسم المستخدم هو : (admin)" & vbCrLf & _ "كلمة المرور هى : (admin)", _ vbOKOnly, _ "تبيـــه هــــام" End Sub جعفر

وعليكم السلام 🙂 ايه يا شيخ ، مالو جعفر 🙂 جعفر

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

اتفضل الملف نسخة من New Microsoft Excel Worksheet.xlsx

بكل بساطة Sub select_My_range() Range("A11:A100").Select End Sub

شكرا لك

اخواني في امثلتكم المطروحة لا يتم اضافة الخط الى مجلد Fonts الا بعد الريستارت ,, ويتطلب تشغيل الاكسس كـ مسؤول.

اتمنى يكون المطلوب Dim FirstDayInWeek, LastDayInWeek As Variant Dim dtmDate As Date dtmDate = Date FirstDayInWeek = dtmDate - Weekday(dtmDate, vbUseSystem) + 1 Me.weekfir = FirstDayInWeek LastDayInWeek = dtmDate - Weekday(dtmDate, vbUseSystem) + 7 Me.weekend = LastDayInWeek FirstDayInWeek = dtmDate - Weekday(dtmDate, vbUseSystem) - 1 Me.txtV_DATE1 = FirstDayInWeek LastDayInWeek = dtmDate - Weekday(dtmDate, vbUseSystem) - 14 Me.txtV_DATE2 = LastDayInWeek Me.firstdaymonth = DateSerial(Year(firstdaymonth), DatePart("m", Enddaymonth), 1) UMfirestWeekandlastweek.rar

وعليكم السلام -تفضل قائمة منسدلة بالبحث.xlsm

لا شكر على واجب فكلنا نتعلم فالمنتدى في المقام الأول تعليمي بالنسبة للأخطاء التي كانت لديك أن في معادلات vlookup مدي نهاية أقل من المدي الذي تعمل فكانت المعالات كمثال =IFERROR(VLOOKUP($D$3;Sheet1!$B$4:$AE$157;2;FALSE);"") فقمت بتعديلها إلى =IFERROR(VLOOKUP($D$3;Sheet1!$B$4:$AE$1003;2;FALSE);"") هذه المعادلة كانت بجانب خلية البحث فجلت النهاية 1003 إذا أردت زيادتها يمكنك تغيير الرقم ويجب التكملة على نفس النفس في الخلايا المجاورة إلى الخلية AH3 لكي يعطي الرسم البياني الرسوم

وعليكم السلام 🙂 اذا اردنا ان نعرف الطلبة اللي مأخذين مادة معينة (رقم المادة) ، فنقدر نعمل استعلامين (او استعلام وجدول) ، ونربطهم بحقل المادة ، فيظهر جميع اسماء الطلبة المأخذين هذه المادة ، ووحتى اذا اردنا ان نعرف الطلبة اللي لديهم نفس المادة (رقم المادة) ، والحاصلين على نفس [النتيجة] ، وعندهم نفس [الصفة] ، فكذلك نربط الاستعلامين (او استعلام وجدول) ، بهذه الحقول ، ويظهر لنا اسماء الطلبة ، ولكن ، كل طالب في سجل مختلف ، وقد يكون الطالب اخذ مادة فقط ، وآخر اخذ جميع المواد ، ولكنك لا تريد هذا كله ، فانت واقعا تريد حقل واحد فيه معلومة الطالب هكذا : [رقم المادة] و [النتيجة] و [الصفة] ، ومن ثم تريد ان تعرف جميع الطلبة الذين يحملون نفس هذه المعلومة ، بالإضافة الى هذا ، فانت لا تريد هذا الحقل لكل [رقم المادة] ، وانما تريد ان تجمع جميع [رقم المادة] و [النتيجة] و [الصفة] لكل المواد اللي اخذها ، يعني تحول السجلات الى سجل واحد ، وتجمع بيانات هذه الحقول مع بعض ، ومن ثم تريد تعمل مقارنة بين نتائج الطلبة ، وتعرف هؤلاء الطلبة المتحدين في هذه البيانات كامله والطريقة اللي عملتها ، هي عمل كود في وحدة نمطية ، نرسل لها بيانات الطالب من الاستعلام qry_ALL_Student والذي مصدر بياناته الاستعلام qry_ALL ، مسلسلة ومفروزة حسب [رقم المادة] و [النتيجة] و [الصفة] ، وتقوم الوحدة النمطية بجمعها ، ثم ارسالها مرة اخرى الى حقل في الاستعلام: السجل السابق = السجل الحالي & "_" & rst![رقم المادة] & "-" & rst![النتيجة] & "-" & rst![الصفة] . وعلى هذا الاساس ، يكون هذا الاستعلام فيه اسم الطالب ، وهذا الحقل ، وهنا نربط هذا الاستعلام ببقية الجداول للحصول على اسم الطالب وووو في استعلام اخير qry_Results ، ونطلب منه عدم تكرار الاسم وعدم إظهار الاسم الذي نبحث عنه ، وهو مصدر بيانات النموذج الفرعي 🙂 جعفر

السلام عليكم هذا مثال لتثبيت الخط داخل الونداوز من داخل ملف الأكسس إضافة خط للونداوز.rar

تفضل 🙂 الطريقة هي: فتح التقرير للمعاينه (بطريقة مخفية) ، في التقرير ، في خانة الفرز ، نرسل اليه فرز النموذج الفرعي ، ثم نعطي التقرير الأمر بالقيام بالفرز ، (وفي سطر آخر كذلك يمكننا ان نرسل اليه تصفية النموذج الفرعي Filter ، ثم يجب ان نعطي التقرير الأمر بالقيام بالتصفية FilterOn) ، ثم نطبع التقرير ، ثم نغلق التقرير . فرز التقرير حسب فرز النموذج الفرعي: DoCmd.OpenReport "Q1", acViewPreview, , , acHidden Reports!Q1.OrderBy = Me.SUB.Form.OrderBy Reports!Q1.OrderByOn = True Dim PauseTime, Start PauseTime = 1 ' Set duration. Start = Timer ' Set start time. Do While Timer < Start + PauseTime DoEvents ' Yield to other processes. Loop DoCmd.OutputTo acOutputReport, "Q1", acFormatPDF, ("RateCard" & Format(Now(), "mmmyyyy hhmmss") & ".pdf"), True DoCmd.Close acReport, "Q1", acSaveNo . وعلى هذا القياس تستطيع عمل تصفية كذلك 🙂 جعفر 1027.test2000.mdb.zip

السلام عليكم الحل فى هذة الحالة بسيط وهو باستخدام اداة الكاميرا وهى اداه بسيطة بتاخد صورة من اى خلية (او مجموعة خلايا ) اكسل وبنفس الابعاد والفورمات للخلية الاصلية كأنها تكست بوكس (بث مباشر ...... جرب تغير شكل ولون وحجم الفونت ..... وحتى خلفية الخلية) وهى كما بالمثال لما تغير الرقم اللى فى الخلية B1 بياخد اربع بطاقات شاملة هذا الرقم A2.rar

الاخ أ.محمود تحياتى لك شاهد المرفق ________2.rar