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

السلام عليكم ومشاركة مع استاذى ومعلمى @دروب مبرمج لانى كنت أفكر فى الحل بأبسط الطرق قمت باستخدام دوال تحويل البيانات لان الحقل المراد التعامل معه حقل نصى ولاننا مستقبلا نريد التعامل مع القيم الرقمية داخل الحقل النصى Sales قمت بعمل استعلام بسيط لتحويل نوع البيانات من نصية الى رقمية من خلال الدالة CLng([sales]) فيكون بناء الاستعلام كالاتى SELECT sales.dname, CLng([sales]) AS FldSales FROM sales; الخطوة الثانية : بعد ذلك الان سوف اتعامل مع هذا الاستعلام وليس الجدول ووضع الكود الاتى على زر الامر على الترتيب الاتى Dim strSQL As String الاعلان عن متغير نصى If IsNull(txtXTop) Or Len(txtXTop) = 0 Then اى ان كان مربع النص txtXTop طول السلسلة النصيه له = 0 اى انه فارغ بدون اى قيم فى هذه الحالة سوف اقوم باسناد جملة الاستعلام البسيط مصدر البيانات الان الى المتغير النصى strSQL strSQL = "SELECT sales.dname, CLng([sales]) AS FldSales FROM sales" اما اذا كان مربع النص txtXTop طول السلسلة النصيه له > 0 اى انه يحتوى على قيم قى هذه الحالة سوف اقوم باسناد جملة الاستعلام الاتية الى المتغير ولكن لان جملة الاستعلام عبارة عن سلسلة نصية سوف اقوم باستخدام دوال تحويل البيانات مرة أخرى ولكن فى هذه المرة اريد تحويل الرقم من مربع النص الى سلسلة نصية لان مربع النص الان هو المتغير الذى يمرر قيمة ال Top لاستكمال صياغة جملة SQL دوى ادنى مشاكل من خلال CStr(txtXTop) قتكون الجملة التى سوق يتم اسنادها بهذا الشكل "SELECT TOP " & CStr(txtXTop) & " * FROM qryData ORDER BY FldSales DESC;" وكانت فكرتى تتمحور حول جعل النموذج يعرض البيانات لذلك سوف اسند الى مصدر بيانات النموذج جملة الاستعلام تبعا للحالة من خلال المتغير Me.RecordSource = strSQL وتم اضافة كود تصيد الاخطاء فى حالة تم استخدام اى شئ يخالف الارقام فى مربع النص على النموذج اعتذر للاطالة واعتذر مسبقا فى جالة وجود اى قصور بسبب محاولتى للابقاء على التصميم دون المساس او التغيير فيه مع محاولة الوصول للنتيجة بأبسط طريق واخيرا المرفق select ( X ) Top.accdb

تفضل هذا التعديل select top.accdb

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

وعليكم السلام أخي الكريم ياسر جرب الكود التالي عله يفي بالغرض بإذن الله تم الاعتماد على العمود R في الورقة الثانية لتسجيل اسم Check Box الذي تم ترحيله تفادياً لترحيله مرة أخرى .. يمكنك إخفاء العمود أو إخفاء القيم في العمود R Sub Test() Dim x, ws As Worksheet, sh As Worksheet, chkBox As CheckBox, r As Long, m As Long, cnt As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Sheets(1) Set sh = ThisWorkbook.Sheets(2) For r = 3 To ws.Cells(ws.Rows.Count, "C").End(xlUp).Row Set chkBox = ws.Shapes("Check Box " & r - 2).OLEFormat.Object x = Application.Match(chkBox.Name, sh.Columns("R"), 0) If IsError(x) Then If chkBox.Value = 1 Then m = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1 sh.Range("A" & m).Resize(, 17).Value = ws.Range("A" & r).Resize(, 17).Value sh.Range("R" & m).Value = chkBox.Name cnt = cnt + 1 End If End If Next r Application.ScreenUpdating = True If cnt > 0 Then MsgBox "Total = " & cnt, 64 Else MsgBox "Nothing Transferred", vbExclamation End Sub

جرب هذه المعادلة =IF(M4*0.0199<1.99,1.99,IF(M4*0.0199>=0.299*F4,0.299*F4,M4*0.0199)) على اعتبار أن قيمة الصفقة هي الخلية F4 بالتوفيق

جرب الكود التالي عله يفي بالغرض بإذن الله Sub Test() Dim x, ws As Worksheet, lr As Long, i As Long, j As Long, startSeq As Long, endSeq As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(1) lr = ws.Cells(ws.Rows.Count, "L").End(xlUp).Row ws.Range("A2:A" & lr).ClearContents For i = 2 To lr j = 0 x = Application.Match(ws.Cells(i, "L").Value, ws.Columns("T"), 0) If Not IsError(x) Then startSeq = ws.Cells(x, "U").Value endSeq = ws.Cells(x, "V").Value Do j = j + 1 ws.Cells(i + j - 1, "A").Value = startSeq If startSeq > endSeq Then ws.Cells(i + j - 1, "A").Value = Empty startSeq = startSeq + 1 Loop Until ws.Cells(i, "L").Value <> ws.Cells(i + j, "L").Value i = i + j - 1 End If Next i Application.ScreenUpdating = True End Sub إذا قمت بحذف صفوف من البيانات سيلزمك تنفيذ الكود من جديد لضبط التسلسل

وعليكم السلام ورحمة الله تعالى وبركاته اليوزرفورم ينقصه عدة اكواد كالتعديل والحدف وبما انك طلبت تصحيح الاكواد الموجودة فقط قم بافراغ اليوزرفورم من الاكواد السابقة وقم بنسخ الاكواد التالية Private Sub CommandButton3_Click() ' بحث Dim sh1 As Worksheet Dim f As Range Set sh1 = Sheet54 lrw = sh1.Cells(Rows.Count, 5).End(xlUp).Row With TextBox11 If .Value = "" Then MsgBox "من فضلك ادخل الاسم الذي تريد البحث عنه يا عم سعد", vbCritical, "تنبيه يا عم سعد": Exit Sub Set f = sh1.Range("E5:E" & lrw).Find(TextBox11.Value, , xlValues, xlWhole, , , False) If Not f Is Nothing Then TextBox1.Value = sh1.Range("C" & f.Row).Value TextBox2.Value = sh1.Range("D" & f.Row).Value TextBox3.Value = sh1.Range("E" & f.Row).Value TextBox4.Value = sh1.Range("F" & f.Row).Value TextBox5.Value = sh1.Range("G" & f.Row).Value TextBox6.Value = sh1.Range("H" & f.Row).Value TextBox7.Value = sh1.Range("I" & f.Row).Value TextBox8.Value = sh1.Range("J" & f.Row).Value TextBox9.Value = sh1.Range("K" & f.Row).Value TextBox10.Value = sh1.Range("L" & f.Row).Value openpic = sh1.Range("M" & f.Row).Value Me.Image1.Picture = LoadPicture(openpic) Me.Image1.Visible = True Else MsgBox "الاسم غير موجود" End If End With End Sub '''''''''''''''''''''''''' Private Sub CommandButton2_Click() ' اظافة Dim ws As Worksheet: Set ws = Sheet54 Dim lastrow As Long lastrow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1 With ws ligne = .Cells(.Rows.Count, "C").End(xlUp).Row + 1 End With ws.Cells(ligne, 4) = Me.TextBox2.Text ws.Cells(ligne, 5) = Me.TextBox3.Text ws.Cells(ligne, 6) = Me.TextBox4.Text ws.Cells(ligne, 7) = Me.TextBox5.Text ws.Cells(ligne, 8) = Me.TextBox6.Text ws.Cells(ligne, 9) = Me.TextBox7.Text ws.Cells(ligne, 10) = Me.TextBox8.Text ws.Cells(ligne, 11) = Me.TextBox9.Text ws.Cells(ligne, 12) = Me.TextBox10.Text ws.Range("C10").Value = 1 With ws.Range("C10:C" & lastrow) .Formula = "=Row() - 9" .Value = .Value End With For I = 1 To 11 Me("Textbox" & I) = "" Next I MsgBox "تم حفظ البيانات بنجاح يا عم سعد", vbInformation, "تنبيه يا عم سعد" End Sub ''''''''''''''''''''''''''''''''''''' Private Sub ListBox1_Click() Me.TextBox11.Value = Me.ListBox1.Column(0) Me.ListBox1.Visible = False End Sub Private Sub TextBox11_Change() 'الى الليست بوكس' جلب جملة البحث If Me.TextBox11.Text = "" Then Me.ListBox1.Visible = False Else Me.ListBox1.Visible = True Me.ListBox1.Clear '------------------------------ Dim lrw Set W = Sheet54 lrw = W.Cells(Rows.Count, 5).End(xlUp).Row l = 0 For Each c In Range("e10:e" & lrw) If c Like TextBox11.Text & "*" Then ListBox1.AddItem ListBox1.List(l, 0) = Cells(c.Row, 5).Value l = l + 1 End If Next c End If End Sub Private Sub TextBox11_DblClick(ByVal Cancel As MSForms.ReturnBoolean) If Not iGblInhibitTextBoxEvents Then TextBox11.Value = "" End If End Sub محمد (2).xlsm

Private Sub Workbook_Open() 'بداية عمل الكود بعد فتح الملف 'قم ببتعديل الوقت بما يناسبك Application.OnTime Now + TimeValue("00:00:10"), "ExportSpecificSheet" End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Option Explicit Sub ExportSpecificSheet() 'حدد مسار الملف Const FolderPath As String = "D:\" 'اسم الملف Const FileName As String = "نسخة من البيان الوقتى" 'حدد اسم الشيت Const SheetName As String = "Sheet2" If Evaluate("Isref('" & SheetName & "'!A1)") Then On Error Resume Next Workbooks(FileName).Close On Error GoTo 0 With ThisWorkbook Application.ScreenUpdating = False .Sheets(SheetName).Copy With ActiveWorkbook Dim ws As Worksheet: Set ws = ActiveSheet With ws.UsedRange .Value = .Value End With Application.DisplayAlerts = False .SaveAs FolderPath & FileName & " " & Format(Now, "dd-mm-yyyy hh-mm-ss") & ".xlsx" 'امتداد الملف Application.DisplayAlerts = True .Close False End With Application.ScreenUpdating = True End With MsgBox "Your's Sheet Exported Now ...", 64 End If End Sub بيان وقتى 2.xlsm

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

اتضح أن المشكلة لم تكن في تعطل الاستعلامات، كنت عامل نموذج (فاتورة) فيه زر حذف للسجل، وقد تعطل هذا الزر واتضح ان العطل دا بيحصل لما بيكون فورم الرئيسية شغال فقط، وهذا كان بسبب وجود تايمر في فورم الرئيسية يقوم بإغلاق فورم login ، لما حذفت التايمر الدنيا ظبطت. طبعا نقلت التايمر الى فورم login ليقوم بإغلاق نفسه بعد (ثانية واحدة). من ضمن المشاكل اللي ترتبت على ذلك هو ان الاستعلام كان بيبقى فارغ (رغم وجود سجلات في الجدول المرتبط بالفورم بتاع "الفاتورة")، وهذا ترتب عليه عدم ظهور للبيانات في التقرير أيضا؛ لأن التقرير يستمد بياناته من الاستعلام. هذا ما حدث..

أتوقع الحل بدمج دالتي VLOOKUP COUNTIF بهذه الطريقة =IFERROR(VLOOKUP(L2;$R$2:$T$13;2;FALSE)-1+COUNTIF($L2:$L$2;L2);"") ترقيم بشروط1.xlsx

اساتذتى على رأيان الاول والثانى وهو ما أميل اليه كانت تلك نصائح من استاذى الجليل ومعلمى القدير و والدى الحبيب الاستاذ @ابوخليل مجتمعا ومقرا وموافقا على على كلام استاذى الجليل ومعلمى القدير و والدى الحبيب الاستاذ @jjafferr إقتباس من كلمات وتوجيهات الاستاذ @ابوخليل

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

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

مشتاقون لافكارك الجميلة استاذ @ابو جودي

وعليكم السلام في الخلية A2 جرب المعادلة التاليه =SUBTOTAL(103, $L$2:L2)

شكرا جزيلا حفظك الله وجزاك الله خيرا في ميزان حسناتك

هلا @ابو جودي هلا بيك باشمهندس طولت الغيبه ...

لو وضعت حلك للمشكلة هنا لكان افضل لمن يبحث عن حل لنفس المشكلة

Daily sales follow-up report.xlsmالسلام عليكم ورحمة الله وبركاته جمعة مباركة على جميع الزملاء والأساتذه الأفاضل بعد إذن أساتذتى الأفاضل مرفق شيت موضح به بيانات أريد كود يقوم بترحيل البيانات المحددة فقط عن طريق ال Check Box علما بأنه يتم تحديد ال Check Box يوما بعد الأخر عندما يتم التسليم مع مراعاة عدم تكرار المحدد والذى تم ترحلية من قبل عند تحديد بيانات أخرى جديدة ولسيادتكم خالص الشكر والتقدير وجزاكم الله خيرا وجعله فى ميزان حسناتكم جميعا Daily sales follow-up report.xlsm

مشكور أخى الحبيب أستاذ / ياسر تم حل المشكلة بالفعل جزاك الله خيرا أخى الفاضل

إستفسار أستاذ / ياسر بعد إذن حضرتك عند عمل حفظ يظهر هذه الرسالة وهل يتم وضع الكود فى Sheet 1 أم يوضع فى Module

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

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

وعليكم السلام ورحمة الله وبركاته.. ماذا تقصد ب هو المتاح ؟؟ وضح السؤال أكثر تكرما

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

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

Public Function MAKEIT1() Call TSFERTABLE1 Dim mada As Recordset Dim MOALEM As Recordset Dim TABLE As Recordset On Error Resume Next '_____________________ Set mada = CurrentDb.OpenRecordset("SELECT * FROM [بيانات المادة] ORDER BY [متتالية] DESC,[الصف]", dbOpenDynaset) Set TABLE = CurrentDb.OpenRecordset("teacher class1", dbOpenDynaset) '_____________________ mada.MoveFirst Do While mada.EOF = False Set MOALEM = CurrentDb.OpenRecordset("SELECT * FROM [بيانات المعلم] WHERE [الصف] = " & mada![الصف] & " AND [المادة] =" & "'" & mada![المادة] & "'" & " ORDER BY [الفصل]", dbOpenDynaset) MOALEM.MoveFirst Do While MOALEM.EOF = False TABLE.FindFirst "[رقم]=" & MOALEM![رقم] Call RECORDHSA(MOALEM, mada, TABLE) MOALEM.MoveNext Loop mada.MoveNext Loop End Function السلام عليكم وكل عام وحضرتكم بخير تم تصميم توزيع جدول حصص المدرسة اليا بجميع مشتملاته وتفاصيلة ولكن لابد من بعض التطوير على البرنامج طبقا لظهور بعض المعواقات التى ظهرت اثناء العمل به علما بان البرنامج الحمد لله يعمل بكفاءة عالية بكل تفاصيلة ومشتملاته الحالية المعوقات اولا – اجبار زر امر التوزيع عند وضع علامة صح امام المادة المختارة ان تكون حصتان متتاليتان او متلاصقتن اجبارى اولا / مرفق نموذج باسم Madah لاجبار الحصص ان تكون حصتان متتاليتان عند وضع علامة صح ومرفق الكود الخاص بهذه المشكلة ولكن للاسف بعض الحصص اثناء التوزيع لم تكون متتالية وبيتم تعديلها يدويا وهناك نموذج باسم توزيع الحصص المسئول عن توزيع الحصص عند الضغط على يوم الاحد يتم التوزيع ملحوظة / لكى تعمل النماذج يحب الضغط على زر التمكين اولا علما بان الصفوف الاول والثانى والثالث الاعدادى عليهم البيانات لتجارب عليهم ومرفق جدول لتسهيل الخبراء التجارب عليه ليوم الاحد فقط والكود المسئول عن الحصص المتتالية ارجو ان يكون الشرح وافى انظر الى جدول يوم الاحد للاستاذ عبد الفتاح والاستاذة لبنى عى سبيل المثال نلاحظ ان هناك حصتان لغة عربية لنفس الفصل بينهما حصتان لمادة اخرى والمطلوب عدم وجود فاصل بين الحصتين تجربة الجدول.rar

تفضل اوفسينا.xlsm

السلام عليكم ورحمة الله وبركاتة بالفعل ماتقوله صحيح تفضل المحترف - 2023-9-م.xlsm

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

حل آخر Sub test2() Dim a Dim i&, c& a = Sheets("sheet1").Cells(5, 1).Resize(Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row - 4) For i = 1 To UBound(a) If a(i, 1) <> "" Then If IsNumeric(Application.Match("جميلة", Split(a(i, 1)), 0)) Then Sheets("جميلة").Cells(c + 1, 1) = a(i, 1) c = c + 1 End If: End If Next End Sub

يمكنك تجربة هذه المحاولة بالمعادلات بدلا من تصدير النتائج في شيت جديد يمكنك كتابة مصطلح البحث والحصول على النتائج في شيت النتائج أهم شيء معادلة المسلسل في شيت البيانات data لأن معادلة البحث vlookup تعتمد عليها بالتوفيق فلترة نتائج البحث في شيت جديد.xls

عليكم السلام ربما Sub test() Dim a Dim i&, c& a = Sheets("sheet1").Cells(5, 1).CurrentRegion.Columns(1) With CreateObject("VBScript.RegExp") .Global = True .Pattern = "جميلة" For i = 1 To UBound(a) If .test(a(i, 1)) Then Sheets("جميلة").Cells(c + 1, 1) = a(i, 1) c = c + 1 End If Next End With End Sub

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

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

السلام عليكم أ. محمد هشام في البداية كل التعازي والمواساة في مصابكم الجليل لك وللشعب المغربي الشقيق نسأل الله العلى القدير أن يتغمد من وافته المنية في هذا الزلزال بعظيم الرحمة والمغفرة وأن ينزلهم منازل الشهداء وأن ينعم ويتم الشفاء على المصابين .. آمين .. أتوجه بالشكر الجزيل على ما قدمته بهذا الصدد وعلى هذا الكود الرائع وعلى شرح محتواه .. دائماً نتعلم منك .. بارك الله فيكم ولكم وكل التحية والاحترام

تفضل اخي تم تعديل الاكواد لتتناسب مع طلبك . Private Sub Worksheet_Change(ByVal Target As Range) ''''''''''''''''''''''''''' الخزينة 1 '''''''''''''''''''''''''''''''' On Error Resume Next ' 'اظافة شرط الفلترة لزر التصفية If Not Intersect(Target, Range("j3")) Is Nothing Then Add_text If Not Intersect(Target, Range("D3")) Is Nothing Then Dim LRow As Long, Réf As Range, data As Range Dim WSData As Worksheet: Set WSData = ThisWorkbook.Sheets("الخزينة1") 'اسم عمود البحث Col = WSData.Range("D3").Text 'خلية القائمة المنسدلة Set cel = [j3] Application.ScreenUpdating = False Application.Calculation = xlManual 'الغاء الفلترة WSData.ShowAllData 'نطاق البحث Set Réf = WSData.Range("D6:O6").Find(Col) If Not Réf Is Nothing Then On Error Resume Next ' افراغ البيانات السابقة WSData.Range("Ad7:Ad" & Range("Ad7").End(xlDown).Row).ClearContents LRow = WSData.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row 'نسخ العمود الهدف WSData.Range(WSData.Cells(7, Réf.Column), WSData.Cells(3325, Réf.Column)).Copy With WSData 'لصق .Range("AD7").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False 'ترتيب ابجدي (رقمي) WSData.Range("AD7:AD" & LRow).Sort Key1:=Range("AD7"), Order1:=xlAscending, Header:=xlNo 'ازالة الفراغات WSData.Range("ad7:ad" & LRow).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp 'ازالة التكرار WSData.Range("AD7", .Cells(.rows.Count, 30).End(xlUp)).RemoveDuplicates Columns:=1, Header:=xlNo [j3].NumberFormat = [AD7].NumberFormat End With ' اظافة قائمة منسدلة مطاطية Set data = Range(Range("Ad7"), Range("Ad" & rows.Count).End(xlUp)) With cel.validation .Delete .Add Type:=xlValidateList, Formula1:="=" & data.Address & "" [j3] = [AD7] End With End If End If [d6].Select Application.CutCopyMode = False Application.Calculation = xlAutomatic On Error GoTo 0 End Sub الخزينة6.xlsb

هذا هو الكود الخاص بالحصتان المتتاليتان Public Function MAKEIT1() Call TSFERTABLE1 Dim mada As Recordset Dim MOALEM As Recordset Dim TABLE As Recordset On Error Resume Next '_____________________ Set mada = CurrentDb.OpenRecordset("SELECT * FROM [بيانات المادة] ORDER BY [متتالية] DESC,[الصف]", dbOpenDynaset) Set TABLE = CurrentDb.OpenRecordset("teacher class1", dbOpenDynaset) '_____________________ mada.MoveFirst Do While mada.EOF = False Set MOALEM = CurrentDb.OpenRecordset("SELECT * FROM [بيانات المعلم] WHERE [الصف] = " & mada![الصف] & " AND [المادة] =" & "'" & mada![المادة] & "'" & " ORDER BY [الفصل]", dbOpenDynaset) MOALEM.MoveFirst Do While MOALEM.EOF = False TABLE.FindFirst "[رقم]=" & MOALEM![رقم] Call RECORDHSA(MOALEM, mada, TABLE) MOALEM.MoveNext Loop mada.MoveNext Loop End Function

السلام عليكم أخي الكريم ، أستاذ سليم حصبيا بارك الله فيك وفي وقتك وجهدك بعد إذنك ، ممكن الحل بلا أكواد يكون أنسب أخي / محمد احمد العصري يمكنك الحل عن طريق فصل العمود إلي ثلاث أعمدة ثم ترتبها كما تريد أنظر الصورة

السلام عليكم تفضل أخي الملف المرفق ترحيل على رقم الفوج.xlsm