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

وعليكم السلام اخى واستاذى @sandanet اتفضل ان شاء الله يكون ما تريد Private Sub Command25_Click() Dim mydb, mydac Dim strSQL As String mydb = IIf(Nz(Me!textbox2.Value) = "", "Null", "#" & Me!textbox2.Value & "#") strSQL$ = ("INSERT INTO table1 ([fullname] , [date_birth]) VALUES('" & Me!textbox1 & "', " & mydb & ")") CurrentDb.Execute strSQL, dbFailOnError subfrm.Requery MsgBox "تم حفظ البيانات بنجاح", vbInformation + vbMsgBoxRight, "تنبيه" End Sub بالتوفيق اخى example(1).accdb

بداية يجب إرجاع الفضل لإهله الاستاذ / سليم حاصبيا - الاستاذ ابراهيم الحداد فى مساعدتهم الدائمة وخاصة فى اعداد هذا البرنامج والذى اتمنى ان يحوز رضاكم كتلميذ من تلامذة المنتدى أمنيتى تعريفى بعيوبه من جانب اساتذتى واسم المستخدم/ محمد فتحى / وكلمة المرور 1970 ومحرر الاكواد / 6101970 1562309003_.rar

شرح كيفية عمل حاسبة calculator فيديو رقم 3 الملف اسفل الفيديو

تم معالجة الأمر اود ان يكون الكود لجلب أسماء المدارس فقط دون اي بيانات اخرى (يمكن التعديل كما تريد) من خلال الــ Loop Sub First_Third_New() Dim sh As Worksheet Dim sh1 As Worksheet Dim My_rg As Range Dim F_rg As Range, xx As Long Dim ro As Long, i As Long Dim k As Byte, m As Byte Dim Cret1, Cret2 Dim arr, Col As Object, Dic As Object Dim Lt, t% Dim Mn Application.ScreenUpdating = False Set sh = Sheets("Salim") Set sh1 = Sheets("Sheet1") Set My_rg = sh.Range("A1").CurrentRegion Set Col = CreateObject("System.Collections.ArrayList") Set Dic = CreateObject("Scripting.Dictionary") sh1.Range("C8:M13").ClearContents ro = My_rg.Rows.Count sh.Cells(2, 1).Resize(ro - 1, 12).Interior.ColorIndex = xlNone If sh1.Range("V8") = "" Then sh1.Range("V8") = "Grade 1" If sh1.Range("V7") = "" Then sh1.Range("V7") = "Arabic Language" Cret1 = sh1.Range("V8"): Cret2 = sh1.Range("V7") If sh.FilterMode Then My_rg.AutoFilter End If My_rg.AutoFilter Field:=1, _ Criteria1:=Cret1 My_rg.AutoFilter Field:=3, _ Criteria1:=Cret2 Set My_rg = My_rg.Columns(13) _ .Resize(ro - 1).SpecialCells(12) Mn = Application.Large(My_rg, 5) If My_rg.Areas.Count = 1 Then arr = Application.Transpose(My_rg) Else arr = Application.Transpose(My_rg.Areas(2)) End If For i = 1 To UBound(arr) If IsNumeric(arr(i)) Then Col.Add Val(arr(i)) End If Next i Col.Sort Col.Reverse For t = 0 To Col.Count - 1 If Col(t) >= Mn Then Dic(Col(t)) = vbNullString End If Next If sh.FilterMode Then My_rg.AutoFilter End If m = 8: t = 0 Do Until t = Dic.Count + 1 Set F_rg = My_rg.Find(Dic.keys()(t) _ , lookat:=1) xx = F_rg.Row: Lt = xx Do sh.Cells(Lt, 1).Resize(, 12).Interior.ColorIndex = 6 With sh1.Cells(m, "C") .Value = sh.Cells(Lt, "B") .Offset(, 1).Resize(, 9).Value = _ sh.Cells(Lt, "D").Resize(, 9).Value .Offset(, 10) = F_rg m = m + 1 End With Set F_rg = My_rg.FindNext(F_rg) Lt = F_rg.Row If Lt = xx Then Exit Do Loop t = t + 1 If t = Dic.Count Then Exit Do Loop Application.ScreenUpdating = True Set sh = Nothing Set My_rg = Nothing: Set F_rg = Nothing Set Col = Nothing: Set Dic = Nothing Erase arr End Sub Masry_Extra.xlsm

قم بتغيير اسم الملف بحيث يحتوي على xls. واحدة لا اثنتين

فكما ترى بنفسك يعمل معى بكفاءة ولا يوجد به اى مشكلة

هذا الكود يدرج التكرار (صفحة Salim من هذا الملف) وضعته في صفحة مستقلة كي لا تتأثر الييانات في الصفحة الاساسية فقط عليك تعديلة كما تريد Sub First_Until_Third() Dim sh As Worksheet Dim My_rg As Range Dim F_rg As Range, xx As Long Dim ro As Long, i As Long Dim k As Byte, m As Byte Dim Cret1, Cret2 Dim arr, Col As Object, Dic As Object Dim Lt, t% Dim Mn Application.ScreenUpdating = False Set sh = Sheets("Salim") Set My_rg = sh.Range("A1").CurrentRegion Set Col = CreateObject("System.Collections.ArrayList") Set Dic = CreateObject("Scripting.Dictionary") sh.Range("P9:Z20").ClearContents ro = My_rg.Rows.Count sh.Cells(2, 1).Resize(ro - 1, 12).Interior.ColorIndex = xlNone If sh.Range("P4") = "" Then sh.Range("P4") = "Grade 1" If sh.Range("P3") = "" Then sh.Range("P3") = "Arabic Language" Cret1 = sh.Range("P4"): Cret2 = sh.Range("P3") If sh.FilterMode Then My_rg.AutoFilter End If My_rg.AutoFilter Field:=1, _ Criteria1:=Cret1 My_rg.AutoFilter Field:=3, _ Criteria1:=Cret2 Set My_rg = My_rg.Columns(13) _ .Resize(ro - 1).SpecialCells(12) Mn = Application.Large(My_rg, 5) arr = My_rg For i = 1 To UBound(arr) If IsNumeric(arr(i, 1)) Then Col.Add Val(arr(i, 1)) End If Next i Col.Sort Col.Reverse For t = 0 To Col.Count - 1 If Col(t) >= Mn Then Dic(Col(t)) = vbNullString End If Next If sh.FilterMode Then My_rg.AutoFilter End If m = 9: t = 0 Do Until t = Dic.Count + 1 Set F_rg = My_rg.Find(Dic.keys()(t) _ , lookat:=1) xx = F_rg.Row: Lt = xx Do sh.Cells(Lt, 1).Resize(, 12).Interior.ColorIndex = 6 With sh.Cells(m, "P") .Value = sh.Cells(Lt, "B") .Offset(, 1).Resize(, 9).Value = _ sh.Cells(Lt, "D").Resize(, 9).Value .Offset(, 10) = F_rg m = m + 1 End With Set F_rg = My_rg.FindNext(F_rg) Lt = F_rg.Row If Lt = xx Then Exit Do Loop t = t + 1 If t = Dic.Count Then Exit Do Loop Application.ScreenUpdating = True Set sh = Nothing Set My_rg = Nothing: Set F_rg = Nothing Set Col = Nothing: Set Dic = Nothing Erase arr End Sub Masry_NEW.xlsm

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

وعليكم السلام-عليك بضبط اللغة العربية لديك ... وبما انك لم تقم برفع الملف فكان عليك استخدام خاصية البحث بالمنتدى-تفضل مشكلة في اللغة العربية

يمكن ذلك بواسطة هذا الكود Option Explicit Sub First_Sec_Third() Dim sh As Worksheet Dim My_rg As Range Dim F_rg As Range, xx As Long Dim ro As Long, i As Long Dim k As Byte, m As Byte Dim Cret1, Cret2 Dim arr, Col As Object Application.ScreenUpdating = False Set sh = Sheets("Data") Set My_rg = sh.Range("A1").CurrentRegion Set Col = CreateObject("System.Collections.ArrayList") sh.Range("P9:Z11").ClearContents ro = My_rg.Rows.Count If sh.Range("P4") = "" Then sh.Range("P4") = "Grade 1" If sh.Range("P3") = "" Then sh.Range("P3") = "Arabic Language" Cret1 = sh.Range("P4"): Cret2 = sh.Range("P3") If sh.FilterMode Then My_rg.AutoFilter End If My_rg.AutoFilter Field:=1, _ Criteria1:=Cret1 My_rg.AutoFilter Field:=3, _ Criteria1:=Cret2 arr = My_rg.Columns(13).Offset(1) _ .Resize(ro - 1).SpecialCells(12) For i = 1 To UBound(arr) If IsNumeric(arr(i, 1)) Then Col.Add arr(i, 1) Next i Col.Sort Col.Reverse If sh.FilterMode Then My_rg.AutoFilter End If m = 9 Do Until m = 12 Set F_rg = My_rg.Find(Col(m - 9), lookat:=1) xx = F_rg.Row With sh.Cells(m, "P") .Value = sh.Cells(xx, "B") .Offset(, 1).Resize(, 9).Value = _ sh.Cells(xx, "D").Resize(, 9).Value .Offset(, 10) = F_rg End With m = m + 1 Loop Application.ScreenUpdating = True Set sh = Nothing: Set Aux_sh = Nothing Set My_rg = Nothing: Set F_rg = Nothing Set Col = Nothing End Sub Masry_collcetion.xlsm

جرب هذا الماكرو (هناك ورقة مخفية مساعدة Sheet1 ) الرجاء عدم مسحها Option Explicit Sub First_Sec_Third() Dim sh As Worksheet Dim Aux_sh As Worksheet Dim My_rg As Range Dim F_rg As Range, xx As Long Dim Cret1, Cret2 Dim ro As Long Dim k As Byte, m As Byte Application.ScreenUpdating = False Set Aux_sh = Sheets("Sheet1") Set sh = Sheets("Data") sh.Range("P9:Z11").ClearContents Set My_rg = sh.Range("A1").CurrentRegion ro = My_rg.Rows.Count If sh.Range("P4") = "" Then sh.Range("P4") = "Grade 1" If sh.Range("P3") = "" Then sh.Range("P3") = "Arabic Language" Cret1 = sh.Range("P4"): Cret2 = sh.Range("P3") Aux_sh.Range("A1").CurrentRegion.Clear If sh.FilterMode Then My_rg.AutoFilter End If My_rg.AutoFilter Field:=1, Criteria1:=Cret1 My_rg.AutoFilter Field:=3, Criteria1:=Cret2 My_rg.Columns(13).Offset(1).Resize(ro - 1).Copy Aux_sh.Range("A1").PasteSpecial (12) Aux_sh.Range("A1").CurrentRegion.SortSpecial , Order1:=2 If sh.FilterMode Then My_rg.AutoFilter End If k = 1: m = 9 Do Until k = 4 Set F_rg = My_rg.Find(Aux_sh.Range("A" & k), lookat:=1) xx = F_rg.Row With sh.Cells(m, "P") .Value = sh.Cells(xx, "B") .Offset(, 1).Resize(, 9).Value = _ sh.Cells(xx, "D").Resize(, 9).Value .Offset(, 10) = F_rg End With k = k + 1: m = m + 1 Loop Application.ScreenUpdating = True Set sh = Nothing: Set Aux_sh = Nothing Set My_rg = Nothing: Set F_rg = Nothing End Sub Masry.xlsm

بارك الله فيك استاذ محمد فؤاد يمكنك استخدام هذا الكود أستاذ حسن للطباعة بدون فراغات Sub Macro4() Range("A1:e350").Select Selection.AutoFilter Selection.AutoFilter Field:=1, Criteria1:="<>" Columns("A:e").Select Range("A1").Activate Selection.PrintOut Copies:=1, Preview:=True, Collate:=True On Error Resume Next Sheet2.ShowAllData On Error GoTo 0 End Sub كشف حساب.xlsm

السلام عليكم 🙂 هذا تعديل على المشاركة اعلاه ، وبه تعمل بقية صيغ الصوت مثل wav و mp3 🙂 الوحدة النمطية التالية ، تعمل على النواتين 32بت و 64بت: Option Compare Database Option Explicit Declare PtrSafe Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" _ (ByVal lpstrCommand As String, _ ByVal lpstrReturnString As Any, _ ByVal uReturnLength As Long, _ ByVal hwndCallback As Long) As Long ' ' the above API will not work if there is a space in the file path, ' so use the old DOS trick to get a short name path for this file, then play it ' Function get8_3FullFileName(ByVal sFullFileName As String) As String ' ' Convert the normal path to the old DOS 8.3 path ' this solves the problem of spaces in the path ' Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject") get8_3FullFileName = FSO.GetFile(sFullFileName).ShortPath End Function Public Sub PlaySound(SoundFile As String) SoundFile = get8_3FullFileName(SoundFile) If mciSendString("play " & SoundFile, 0&, 0, 0) <> 0 Then MsgBox "The Sound Did Not Play!" End If End Sub Public Sub StopSound(SoundFile As String) SoundFile = get8_3FullFileName(SoundFile) If mciSendString("close " & SoundFile, 0&, 0, 0) <> 0 Then MsgBox "Could't stop The Sound!" End If End Sub . ومن النموذج ناديها هكذا : اذا كان ملف الصوت في نفس ملف البرنامج Private Sub Form_Current() Call PlaySound(Application.CurrentProject.Path & "\ringin.wav") 'Call PlaySound(Application.CurrentProject.Path & "\ringin.mp3") End Sub او في اي ملف آخر Private Sub Form_Current() Call PlaySound("D:\mySounds\ringin.wav") 'Call PlaySound("D:\mySounds\ringin.mp3") End Sub جعفر Play Sound.zip

وعليكم السلام 🙂 احنا عادة نتعامل مع اصحاب الهمة ، بس الآن تعاملنا بالهمة شخصيا 🙂 مو علوم خبر 🙂 استعمل الوحدة النمطية التالية ، اللي تعمل على النواتين 32بت و 64بت: Option Compare Database Option Explicit Declare PtrSafe Function apisndPlaySound Lib "winmm" Alias "sndPlaySoundA" _ (ByVal filename As String, ByVal snd_async As Long) As Long Function PlaySound(sWavFile As String) ' Purpose: Plays a sound. ' Argument: the full path and file name. If apisndPlaySound(sWavFile, 1) = 0 Then MsgBox "The Sound Did Not Play!" End If End Function . ومن النموذج ناديها هكذا : اذا كان ملف الصوت في نفس ملف البرنامج Private Sub Form_Current() Call PlaySound(Application.CurrentProject.Path & "\ringin.wav") End Sub او في اي ملف آخر Private Sub Form_Current() Call PlaySound("D:\mySounds\ringin.wav") End Sub جعفر Rulesets.zip

try This macro Option Explicit Private Sub Worksheet_Change(ByVal Target As Excel.Range) Application.EnableEvents = False Dim My_Address$ My_Address = Target.Offset(8, 2).Address If Not Intersect(Target, Me.Range("B2:B5")) Is Nothing _ And Target.Cells.Count = 1 Then Me.Range(My_Address) = Target.Value Sheets("close").Range(My_Address) = Target End If Application.EnableEvents = True End Sub File Inclided Walid.xlsm

NF.accdb

السلام عليكم هذا برنامج كشوف المناداة توزيع كل الطلاب كل 3 لجان فى صفحة على خير ما تحبون تفضلوا مع إبداء الآراء يعمل على 2007 ونسخة ل 2003 توزيع اللجان.zip توزيع اللجان2003.zip

وعليكم السلام اخى @abouelhassan اتفضل شوف التقرير هل هذا ما تريد ؟ واعطنى اسم يوزر وباسورد للاطلاع ع ما تريد بالتوفيق 1311.11.DATA12.rar

أخي Ali Mohamed Ali جزاك الله خيرا فقد تم حل المشكلة بعد ان غيرت بعض الاعدادات - على سبيل التجربة - كما بالصور التالية

انظر الصورة وحاول ربما

جرب هذا الكود Sub test() Dim lr, lr2, lrw Dim x, w, dt, rg Application.ScreenUpdating = False lr = Cells(Rows.Count, 1).End(xlUp).Row Range("n6:p10000").ClearContents For x = 6 To lr Set rg = Cells(x, "c") dt = Cells(x, "b") If Cells(x, "c") >= 1 Then lr2 = Cells(Rows.Count, "n").End(xlUp).Row For w = 1 To rg lrw = Cells(Rows.Count, "p").End(xlUp).Row If dt = CDate(Range("p3")) Then GoTo 1 Range("n" & lrw + 1) = Cells(x, 1) Range("O" & lrw + 1).Value = Format(DateAdd("m", 1, dt), "mm-yyyy") Range("p" & lrw + 1).Value = rg - 1 dt = Format(DateAdd("m", 1, dt), "mm-yyyy") rg = rg - 1 Next w End If 1: Next x Application.ScreenUpdating = True End Sub

جزاكم الله خيرا وشكر لكم

أ. abouelhassan فى حقل iAmount لا تترك حقول فارغة .. رتبه من الاصغر ثم ضع قيمة لكل الحقول الفارغة إن وجدت ولتكن 0 جرب ووافنى بالنتيجة

نعم ، بعمل ثلاث تغييرات : . جعفر 1348.ترقيم خاص.accdb.zip

يجب عليك تفعيل الماكرو اولا حتي يعمل معاك التكست بوكس للبحث

انت على الدرب الصحيح

[ميل الحل لكن مثالي أو المشكله تكمن عندي في وجود دالة if في العمليه الحسابيه مثالك لا يوجد به دالة if

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

بس حلك ابطأ من حللي ، لسبب : نوع الحقل في الجدول عبارة رقم ، ومعرّف انه Double ، فقمت انت في الدالة بتغيير نوعه الى Variant ، وارجعت القيم الى الاستعلام كنص (لما يكون محاذاة القيمة في الحقل ، الى اليمين ، فمعناه انه رقم او تاريخ ، بينما اذا كانت محاذاته الى اليسار فيكون نص) ، ثم رجعت في الاستعلام (او النموذج) وغيرته الى Double ، وفي حقل المجموع في النموذج استعملت الدالة NZ مرة اخرى ، والتي كذلك تحتاج الى وقت للقيام بعملها 🙂 اما طريقتي جعفر

جزاك الله خيرا اخى ومعلمى العزيز @jjafferr 💐 من الامس وانا بضرب اخماس فى اسداس بسبب هذا الخطأ الى ان هدانى الله اليوم لازالة تعريف المتغيرات وحصلت على خطأ قيم فارغه فقمت باستخدام nz ولم يخطر ببالى استخدامها داخل الاستعلام جزاك الله خيرا معلمى العزيز

السلام عليكم 🙂 الاكسس 2010 لم يستطع فتح المرفقات جميعا ، وحصلت على هذه الرسالة (مع ان الاكسس عندي يتم عمل له تحديث تلقائي) : . فاضطررت ان استعمل الاكسس 2019 ، واحول البرنامج الى صيغة mdb ، حتى اتعامل معاه على الاكسس 2010 !! شكرا اخوي احمد ، وبسبب ملاحظتك عن وجود حقول فارغة ، فتوصلت الى هذا الحل ، والذي يحاكي حلك ، ولكن يتفاعل مع اصل البيانات الفارغة من الاستعلام قبل ارسالها للدالة ، اما اذا ارسلت البيانات الغير كامة الى الدالة ، فستضطر ان لا تصرح عن المتغير في الدالة على انه Double 🙂 ) . والنتيجة: . جعفر 1346.price_fa.mdb.zip

شكرا اخى ابواشرف @عبد اللطيف سلوم على المساعده ولكن ليس هذا المطلوب المطلوب هو جمع عمود القيم الناتج عن الفنكشن اتفضل اخى @Matin_Murad تم تغيير بسيط فالفنكشن Function test(a, b) test = Nz(a, 0) * Nz(b, 0) End Function بالتوفيق اخوانى price_fa(2).accdb

وعليكم السلام-تفضل لك ما طلبت بالتنسيقات الشرطية بعد ضبط تنسيق التواريخ بصفحة التقويم Training Plan - Master - Final 2021.xlsx

جرب Copy of Copy of نموذج بيانات.xlsm

price_fa.accdb

بالموضوع مجموعة من الاجابات والأفكار المختلفة أي شىء جربته ولم يفلح معك علي 2013 نرجو التوضيح

ما العمل وانت تقومين بتشكيل ملف مع صفحات غير منتظمة من حيث النتسيق في الصورة الرقم المستندى في عامود (C) في صفجة وفي عامود اخر D في صفحة اخرى لاخر مرة أقوم بالتصحيح فلا وقت للعمل يهذه الأمور (لان الكود يجب ان يبحث عن الرقم المستندى في عامود مجدد) الكود الجديد Option Explicit Sub Get_Data() Dim Arr_SH(), t% Dim Arr_Number() Dim NO_arr, n%, K% Dim x As Boolean Dim Special_SH As Worksheet Dim sh As Worksheet, My_sheet As Worksheet Dim ro%, Col%, m%, i% Dim F_rg As Range NO_arr = Array("تقرير تجميعى", "تقرير2", "تقرير3", "تقرير4", _ "تقرير5", "تقرير6", "تقرير7") Set Special_SH = Sheets("تقرير تجميعى") Application.ScreenUpdating = False K = 1 For i = 1 To Sheets.Count x = IsError(Application.Match(Sheets(i).Name, NO_arr, 0)) If x Then ReDim Preserve Arr_SH(1 To K) ReDim Preserve Arr_Number(1 To K) Arr_SH(K) = Sheets(i).Name: Arr_Number(K) = K K = K + 1 End If Next i m = 2 Special_SH.Range("A1").CurrentRegion.Offset(1).Clear For t = LBound(Arr_SH) To UBound(Arr_SH) Set sh = Sheets(Arr_SH(t)) ro = sh.Cells(Rows.Count, 1).End(3).Row Col = sh.Cells(1, Columns.Count).End(1).Column For i = 5 To ro If sh.Cells(i, 1) = vbNullString Then GoTo next_I If Application.CountA(sh.Cells(i, 4).Resize(, Col - 4)) = 0 Then GoTo next_I Special_SH.Cells(m, 2).Resize(, 2).Value = _ sh.Cells(i, 1).Resize(, 2).Value Set F_rg = sh.Cells(i, 3).Resize(, Col - 3). _ Find("*", after:=sh.Cells(i, 3)) If Not F_rg Is Nothing And F_rg.Column <= Col Then With Special_SH.Cells(m, 4) .Value = F_rg '+++++++++ By choise You can insert _ ' Sheets name or Sheet Number++++++++++++ ' .Offset(, 1) = Arr_Number(t) .Offset(, 1) = sh.Name '++++++++++++++++++++++++++++++++++ ' .Offset(, 2) = sh.Cells(1, F_rg.Column) .Offset(, 3) = sh.Cells(i, 3) .Offset(, -3).Resize(, 7).Interior.ColorIndex = _ IIf(n Mod 2 = 0, 24, 36) End With m = m + 1 End If next_I: Next i Rem sh.Cells(5, 3).Resize(ro - 4, Col - 2).ClearContents n = n + 1 Next t If m > 2 Then With Special_SH.Range("A2:G" & m) .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 14 .InsertIndent 1 .Columns(1) = Evaluate("row(1:" & m - 2 & ")") With .Rows(m - 1) .Cells(1) = vbNullString .Cells(5) = "Sum" .Cells(4).Formula = _ "=SUM(D2:D" & m - 1 & ")" .Interior.ColorIndex = 40 .Value = .Value End With End With End If Application.ScreenUpdating = True End Sub Yara_New_.xlsm

هذا تبرير منطقي ومعقول.. خرجت من المثال المرفق بالتصور التالي.. اختر التقرير من مربع التحرير، ومن ثم انقر على معرف العميل لترى البيانات الخاصة بذلك العميل.. إذا نقرت على معرف العميل قبل اختيار التقرير من مربع التحرير تظهر سالة تنبيه.. testreport.accdb

السلام عليكم ورحمة الله ضع المعادلة الاولى فى الخلية J4 ثم اضغط Ctrl+Shift+ Enter ثم اسحب نزولا لآخر خلية يمكن ظهور بيانات فيها =IFERROR(INDEX($C$4:$D$20;SMALL(IF(LEFT($C$4:$C$20;LEN($H$3))=$H$3;ROW($C$4:$C$20));ROW(A1))-3;1);"") ضع المعادلة الثانية فى الخلية K4 و كرر ماسبق =IFERROR(INDEX($C$4:$D$20;SMALL(IF(LEFT($C$4:$C$20;LEN($H$3))=$H$3;ROW($C$4:$C$20));ROW(B1))-3;2);"") بحث.xlsx

تفضل بحث.xlsx

تمام وجميل انك تحاول مع الاستفسار ما اسم النموذج المطلوب العمل عليه ؟ بالتوفيق

لا زلت أتعجب؛ لمذا تريد أن تفتح التقارير عن طريق البينة الغرضية وليس باستخدام الطريقة التقليدية! المهم هنا هو إدراج اسماء التقارير في مربع تحرير .. يمكن فعل ذلك عن طريق إنشاء استعلام (تحديد بيانات) من جدول كائنات النظام (MSysObjects) يرجع اسم الغرض من الحقل (Name) وسيكون المحدد هو نوع الغرض من الحقل (Type) ومعرف النوع للتقارير هو (32764-).. SELECT MSysObjects.Name FROM MSysObjects WHERE (((MSysObjects.Type)=-32764)); توضع وصلة الاستعلام هذه في مصدر الصف (Row Source) لمربع التحرير،، يمكن فتح التقرير بعد اختيار التقرير مباشرة (في وضع المعاينة قبل الطباعة ) إذا ما وضعنا التعليمة التالية في حدث بعد التحديث (AfterUpdate) لمربع التحرير DoCmd.OpenReport Me.Combo#, acViewPreview '-- قيمة مربع التحرير والسرد testreport.accdb

أهلا محمد،، فقط افتح التقرير في وضع التصميم،، ثم اذهب إلى محرر الشفرة الخاصة بالتقرير،، ثم انقر على أيقوتة الحفظ،، ثم أغلق التقرير!! السبب أنك أسندت متغير التقرير إلى البنية الغرضية للتقرير،، وفي العادة أكسس لا ينشيء هذه البنية إلا عند فتح محرر الشفرة..

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

اضافة الي ما تقدم به أساتذتي ربما مع اختلاف المدخلين للبيانات يدويا أن يكون قد حدث اختلاف في طريقة الادخال مثلا ربما كان أحدهم يفضل ادخال التاء المربوطة هاء أو الياء ياءا منقوطة بآخر الكلمات - مما يؤدي لتكرار بيانات العميل الواحد أكثر من مرة , مما سيجعل البحث عن اسم العميل به صعوبة شيئا ما- وقد واجهتنا هذه المشاكل كثيرا.. لذا كان اقتراحي أن يتم وضع مربع نص للبحث عن رقم الهوية فان كان موجودا , يتم ملئ باقي بيانات العميل تلقائيا والا فيتم التوجيه الي شاشة ادخال البيانات . وهذا مثال بسيط علي هذه الفكرة. SearchWithpesounCard.rar

تفضل قمت بتصميم قاعدة حسب رغبتك وبالمواصفات المذكوره أعلاه آمل التجربة . Visitors.mdb

بالتأكيد لا يوجد حل فهذه ليست فى نسخة 2016 فقط بل فى كل ملفات الأوفيس على اختلاف انواعه ونسخه

السلام عليكم استبدل هذه الاكواد للفورم Private Sub CommandButton1_Click() Dim i As Integer '''''''''''''''' CommandButton1.Visible = False '''''''''''''''' With Me.MultiPage1.Pages For i = 0 To .Count - 1 If Val(.Item(i).Controls(0).Caption) Then kh_v i UserForm1.Printform End If Next End With kh_Start End Sub Private Sub kh_v(P As Integer) Dim i As Integer '''''''''''''''' With Me.MultiPage1.Pages For i = 0 To .Count - 1 If .Item(i).Index = P Then .Item(i).Visible = True Else .Item(i).Visible = False End If Next End With End Sub Private Sub kh_Start() Dim i As Integer, t As Integer '''''''''''''''' With Me.MultiPage1.Pages For i = 0 To .Count - 1 t = Val(Cells(i + 1, "A")) .Item(i).Controls(0).Caption = t .Item(i).Visible = t Next End With ''''''''''''''''''''''''''''' CommandButton1.Visible = True End Sub Private Sub UserForm_Activate() kh_Start End Sub المرفق 2003 طباعة في فورم لصفحات MultiPage.rar