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

تفضل 🙂 1551.Relink.zip

CurrentDb.Properties("StartUpForm")="myForm"

بعد التعديل حسب طلبك. التكرار في اللجان_03.xlsm

كنت مستغرب من ابو البشر يسأل هذا السؤال البسيط ، والآن عرفنا السبب 😁 هل انت متأكد ان اسم النموذج "Form.frm-UserLogon" وليس "Form.frm_UserLogon" او "frm-UserLogon" او "frm_UserLogon" شوف اسم النموذج اذا صحيح

تفضل <>><>< هههههه Relink.rar

انا استعمل Macro اسمه Autoexec والذي معناه انه اول شيء يشتغل عند فتح الاكسس ، وفيها اضع اسم النموذج الذي اريد فتحه ، او الدالة في الوحدة النمطية اللي اريدها تشتغل 🙂 جعفر

السلام عليكم حسب فهمي للموضوع عملت لك بحث في كل الحقول سواء كان في بداية الكلمة او في نهايتها مع معاينة التقرير والذي يمكن طباعته تحياتي العمال.accdb

سأحاول الليلة إن شاء الله فإن وفقت في الحل رفعته لك. مع المعذرة .. حققت لك جزء من طلبك واسمح لي بالتوقف عند هذه النقطة موفقين. التكرار في اللجان_04.xlsm

ما شاء الله تعددت الحلول الاستاذ ابو بسملة فكرة حلوة الأستاذ سامي : جرب تحذف تاريخ من التواريخ الموجودة ثم شغل الفورم انا عدلت على الحقل في الاستعلام فقط fmmm4.rar

وهنا أيضا قمت بعمل كود لإضافة السجلات وترقيمها 🙂 وهذا هو الكود : Sub Add_2000_Record() Dim x As Long For x = 1 To 2000 CurrentDb.Execute "INSERT INTO Ta1 ( IDD ) VALUES (" & x & ");" Next End Sub إضافة2000سجل.rar

جرب هذا المرفق ووافنا بالنتائج اكتب عدد السجلات المطلوبة واضغط علي زر اضافة سجلات فارغة نموذج.rar

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

أخي مصطفى .. الأكسس يقدم لك طرق سهلة لاستيراد البيانات من مصادر خارجية كالأكسل أو قاعدة أكسس أخرى أو قواعد البيانات الأخرى .. وسائل غير النسخ واللصق 🙂 وكان سؤال المهندس جعفر عن مكان تخزين بيانات هؤلاء ال 2000 موظف لينطلق بك وبنا إلى الوسائل السهلة لاستيراد هذه البيانات لبرنامجك .. 🙂

الدرس الاول في UserForm عناصر الدرس 1- اضافة التبويبات الرئيسية للفورم 2- اضافة MultiPage والتحكم في الانتقالات بينها من خلال التبويبات الرئيسة باستخدام Class Module اولا : اضافة التبويبات الرئيسية 1- نقوم باضة userForm ثم نضيف اطار Frame ونضيف داخله عدد 5 Lebel بالنسبة لعنوان اكتب ما تشاء عربي انجليزي لكن المهم Label Name ( Btn1-Btn2-Btn3-Btn4) ا BackStyle =0 BorderStyle=0 واليبل الخامس لتغير خلفية النص Name=AnlBtn BackColor=&H8000000E& ثم نضيف ليبل خاص بالعنوان نسميه PageNo ثم نضيف MultiPage ونضيف في ال Page1 ثانيا ربط التبويبات بالفورم نضيف Class Module نكتب داخله الكود التالي Public WithEvents LblBtn As MSForms.Label Private Sub LblBtn_Click() ' للحركة بين التبويبات UserForm1.AniBtn.Left = LblBtn.Left 'ربط صفحات المالتي بيج مع التبويبات UserForm1.MultiPage1.Value = Right(LblBtn.Name, 1) - 1 'شريط العنوان UserForm1.PageNo.Caption = "Page No " & UserForm1.MultiPage1.Value + 1 & " ( " & LblBtn.Caption & " )" End Sub وفي الفورم Dim LblEvent(3) As New Class1 Private Sub UserForm_Initialize() With Me.MultiPage1 'لتغير استايل المالتي بيج .Style = fmTabStyleNone: .Value = 0 End With 'عدد التبويبات 4 من صفر الي 3 For AddEvent = 0 To 3 Set LblEvent(AddEvent).LblBtn = Me("Btn" & AddEvent + 1) Next AddEvent End Sub الملف بالمرفقات ياريت ننفذ الخطوات ولو اي استفسار ماتترد اتمني من الله اكون بسط الشرح ويكون فيه الاستفادة مع تحياتي MultiPage Officana.xlsm

Generate PDF Dahy VBA Skills fun موضوعنا النهاردة موضوع شيق مدخل للدرس الثالث للفورم التفاعلي وفي نفس الوقت ها نتعرف فيه علي أدوات ها توفر الوقت والمجهود لشريحة كبيرة تستخدم قالب معين مثل الموارد البشرية لما ترسل طلبات التوظيف المالية لمطابقات كشوف الحساب للموردين واحنا داخلين علي موسم الجرد الختامي والبنوك او الشركات او المواقع التي ترسل رسائل دورية وما الي ذلك انا اخترت المثال علي شئون الموظفين وطلبات التوظيف وهانتعرف علي كيفية التعديل علي النموذج Word عن طريق الفورم عناصر الدرس ملف Templet word القالب المستخدم اداة Microsoft Outlook 16.0 Object Library أداة Microsoft Word 16.0 Object Library ونتعلم مع بعض VBA Dynamic Code وكيفية عمل ملف PDF وارساله بالايميل الشرح نقوم بإضافة الأدوات في الفيجوال كما يلي من Tools نختار References Microsoft Outlook 16.0 Object Library اضافة أداة Microsoft Word 16.0 Object Library تحديد مسار القالب كما يلي شفت + كليك يمين علي ملف الوورد ثم نختار Copy as Path حسب موقع الملف علي جهازك انا عندي في برتيشن F "\F:\GeneratePDF\Template_Contract.docx" تحديد مسار حفظ ملفات PDF الذي يحفظها البرنامج F:\Generate and Preview طبعا يلي مش عارف يغير في الكود يقوم بحفظ الملف المرفق علي برتيشين الFبعد فك الضغط مباشرة . ملف الورد يلي نستخدمه كقالب ولاحظ المسميات يلي انت ظللتها بالاصفر نفس مسميات الليبل ف الفورم وضعتها بين علامتي ##لانها بيانات متغيرة سيتم اضافاتها من الفورم لاحظ معي عند استدعاء الملف بالورد شاهد النتيجة البرنامج اضاف البيانات المظلله بشكل تلقائي الوظيفة الثانية للبرنامج اني ببعت الملف بالايميل من البرنامج لتوفير الوقت والوظيفة في حالة التقارير الدورية او النشرات او حسب استخدام الفرد الذي يحتاج ارسال عدد كبير في نفس الوقت مع ملاحظة انه بشكل تلقائي بياخد الايميل من الفورم ويضيف اسم الموضوع والمرفقات كما بالكود بشكل تلقائي طبعا الشرح موجز لاهم العناصر انا برفق مع الشرح مثال عملي منه للشرح ومنه نستفيد منه او من الافكار يلي فيه وبكون منتظر حد يسال عن اي شئ داخل الملف بصدر رحب لكن للاسف كعادتنا نحفظ في الارشيف علي اية حال الملف بالمرفقات واي استفسار لا تترد كلنا بنتعلم مع بعض شارك وتفاعل انت تسال وذلك يسال واخر يجيب وكلنا هانستفيد الدرس القادم ان شاء الله هاشرح الاكواد ونتعرف علي كود الحغظ والتعديل والبحث الديناميكي لضمان عمل الملف اتبع الشرح السابق في اضافة الادوات ومسار الملف وبالتوفيق للجميع ولا تنسونا من دعائكم بظهر الغيب بصلاح الحال GeneratePDF.rar

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

كنت ولازلت انسان اتعلم وبسيط لا ارتقى الى شريف علمكم بارك الله فيك 😉 نعم لان البرنامج كان يعمل ... ولازال يعمل على اوفيس 2007 ويندوز 7 جهازي حاليا :: ويندوز 10 64Bit اوفيس 19

تفضل 🙂 1553.Database1.accdb.zip

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

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

جزاك الله خير يا اخ احمد Ahmed_J ما قصرت ضبطت معي ... الله يعطيكم العافية

Try this code Sub Test() ExportAsPDF "Cards" End Sub Public Sub ExportAsPDF(ByVal sOut As String) Dim ws As Worksheet, s As String For Each ws In ThisWorkbook.Worksheets If InStr(ws.Name, Chr(199) & Chr(225) & Chr(200) & Chr(216) & Chr(199) & Chr(222) & Chr(201)) Then s = s & IIf(s <> Empty, ",", Empty) & ws.Name Next ws PrintToPDF Split(s, ","), ThisWorkbook.Path & "\" & sOut & ".pdf" End Sub Public Sub PrintToPDF(arr, sFileName As String, Optional vQuality = xlQualityStandard, Optional vIncDocProperties = True, Optional vIgnorePrintAreas = False, Optional vOpenAferPublish = False) ThisWorkbook.Sheets(arr).Select ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sFileName, Quality:=vQuality, IncludeDocProperties:=vIncDocProperties, IgnorePrintAreas:=vIgnorePrintAreas, OpenAfterPublish:=vOpenAferPublish ActiveSheet.Select End Sub

بالاضافة لما تفضل به الاستاذ @kkhalifa1960 جزاه الله خيرا اليك مشاركتي Option Compare Database Option Explicit Dim strSQL As String Dim rs As DAO.Recordset Private Sub CmdClear_Click() Me.TEXT_CHERCHE = "" Me.Query_no_subform.Form.Filter = "" Me.Query_no_subform.Form.FilterOn = False End Sub Private Sub TEXT_CHERCHE_Change() strSQL = "numéro_coud LIKE " & Chr(34) & Me.TEXT_CHERCHE.Text & "*" & Chr(34) Me.Query_no_subform.Form.Filter = strSQL Me.Query_no_subform.Form.FilterOn = True Set rs = Me.Query_no_subform.Form.Recordset If (rs.RecordCount <> 0) Then rs.MoveFirst Do Until rs.EOF rs.Edit rs![oui/non] = True ' change "chkBoxFieldName" with the actual name of your checkbox field rs![date_à_regler] = Date ' change "dateFieldName" with the actual name of your date field rs.Update rs.MoveNext Loop Else MsgBox "السجل المطلوب تم التحقق منه سابقا بتاريخ " End If End Sub Private Sub cmdPrintPreview_Click() Me.TEXT_CHERCHE.SetFocus strSQL = "numéro_coud LIKE " & Chr(34) & Me.TEXT_CHERCHE.Text & "*" & Chr(34) ' Open the report in print preview mode DoCmd.OpenReport "MyReport", acViewPreview, , strSQL End Sub وهذا ملفك بعد التعديل. هل هو المطلوب؟ بالتوفيق my PR.accdb

شكرا ابو احمد على المعلومة ، واتضح ان Int يصلح كذلك 🙂 int([DateTime]) او fix([DateTime])

هل ممكن ان ترفق ملفك حتى نرى اين المشكلة ؟ وجرب هذا التعديل Private Sub Form_Load() Dim OldLong As Long Dim nodX As Node Set nodX = TreeView1.Nodes.ADD(, , "R", "أعدادات النظام", 3) Set nodX = TreeView1.Nodes.ADD("R", tvwChild, "C1", "بيانات الشركة", 2) Set nodX = TreeView1.Nodes.ADD("R", tvwChild, "C2", "بيانات مستخدمي النظام", 5) Set nodX = TreeView1.Nodes.ADD("R", tvwChild, "C3", "كلمات المرور", 1) Set nodX = TreeView1.Nodes.ADD("R", tvwChild, "C4", "بيانات المطورين", 4) nodX.EnsureVisible OldLong = GetWindowLong(TreeView1.hwnd, GWL_EXSTYLE) SetWindowLong TreeView1.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL InvalidateRect hwnd, 0, False Dim formsDictionary As New Scripting.Dictionary formsDictionary.ADD ChrW(&H62A), "frmCompany" formsDictionary.ADD ChrW(&H622), "frmSystemUserData" formsDictionary.ADD ChrW(&H643), "frmPassword" formsDictionary.ADD ChrW(&H62C), "frmDeveloper" End Sub Private Sub TreeView1_Click() Dim strFormName As String Dim formsDictionary As New Scripting.Dictionary formsDictionary.ADD "بيانات الشركة", "frmCompany" formsDictionary.ADD "بيانات مستخدمي النظام", "frmSystemUserData" formsDictionary.ADD "كلمات المرور", "frmPassword" formsDictionary.ADD "بيانات المطورين", "frmDeveloper" strFormName = TreeView1.SelectedItem.Text If formsDictionary.Exists(strFormName) Then DoCmd.OpenForm formsDictionary(strFormName) Else MsgBox "عذرا هذا النموذج غير موجود", vbExclamation, "تنبيه" End If End Sub ولك بمثل ما دعوت أخي الدكتور محمد تحياتي

ويمكن استحصال التاريخ فقط باستخدام دالة Fix أيضا.

السلام عليكم ورحمه الله وبركاته مشاركه مع اخوانى واساتذتى افتح النموذج frmleave واطلع على مصدر السسجلات بعدالتعديل zofdate: werEjaza(Nz([strdate];#01/01/1900#);Nz([enddate];#01/01/1900#)) بالتوفيق fmmm2.accdb

وعليكم السلام 🙂 تفضل جعفر

المطلوب هو أن ترسل الملف حتى نعدل على الكود لأنه يصعب الكلام في البرمجة عند عدم وجود الملف

إذا هذا هو الشهر الذي نبحث عنه استاذنا @ابوخليل وانا - واعوذ بالله من كلمة انا- اتيت بها يا رجل - جزاك الله خيرا

تفضل أخي ووافني بالرد 1585909217_myPR-1.accdb

وطريقة اخرى للنسخ واللصق ، في الاكسل مثلا ، نظم الحقول بنفس ترتيب الحقول في الاكسس ، او في الاكسس نظم الحقول بنفس ترتيبها في الاكسل (يعني امسك الحقل و خليه يزحف يمين ويسار) ، ومو لازم جميع الحقول تكون متساوية في الاكسل والاكسس ، في الاكسل اعمل نسخ للاعمدة المطلوبة ، وفي الاكسس اختار في سجل جديد (مكان وجود النجمة) ، ثم اختار الحقول المتسلسلة من الاكسس (يعني مو كل الحقول) ، ثم الصق 🙂 وعلشان ترتيب الحقول في الجدول ما تخترب عليك ، اغلق الجدول بدون ان تعمل له حفظ : . جعفر

اريدك تتمعن في طريقة عرض وتنسيق ومحاذاة الاكسس لبيانات الحقول ، وهو نفس التنسيق سواء للجداول او الاستعلام او النماذج او التقرير في الصورة التالية ، ترى جزء من بيانات الجدول ، وتحته 3 طرق لعرض التاريخ في الاستعلام : . من تنسيق/محاذاة القيم في الجدول ستعرف محاذاة التاريخ الصحيحة (نفس الشئ ينطبق على حقل النص او التاريخ او الرقم) ، فالمفروض تعرف اي الطرق الثلاثة من الاستعلام صحيحة 🙂 . . جعفر New Microsoft Access Database.zip

السلام عليكم 🙂 اخوي ابو البشر ، الافضل ان تحذف الرابط الحالي قبل ان تعمل رابط جديد ، وتتعامل مع النسخة xlsx 🙂 If tdf.Name = "shet_Data" Then Call CurrentDb.TableDefs.Delete(tdf.Name) DoCmd.TransferSpreadsheet acLink, acSpreadsheetTypeExcel12Xml, _ "shet_Data", CurrentProject.Path & "\Data.xlsx", True, "ورقة1$" End If جعفر

السلام عليكم ورحمه الله وبركاته وبها نبدأ 1- مرحبا بك في المتتدي وفي المشاركه الاولي لك في المنتدي 2- هذا الموضوع يخالف قواعد المنتدي 3- ان كان باسوورد فتح الملف من الصعب معرفته

وعليكم السلام ورحمة الله لاتنتظر مساعده دون ارسال ملف مدعوم بشرح

طيب جرب كده .................. Relink.rar

عليكم السلام ورحمة الله وبركاته تفضل أخي الكريم Sub test() With Sheets("يومية الحضور والإنصراف").Range("B4:C" & Sheets("يومية الحضور والإنصراف").Cells(Rows.Count, 1).End(xlUp).Row) .Formula = "=IFERROR(VLOOKUP($A:$A,Table9,COLUMN(),0),"""")" .Value = .Value End With With Sheets("رصيد الأجازات").Range("B3:D" & Sheets("رصيد الأجازات").Cells(Rows.Count, 2).End(xlUp).Row) .Formula = "=IFERROR(VLOOKUP($A:$A,Table9,COLUMN(),0),"""")" .Offset(, 3).Resize(, 1).Formula = "=IFERROR(IF(DATEDIF([@[تاريخ التعيين]],$D$1,""D"")/30>3.1,""يستحق"",""""),"""")" .Offset(, 5).Resize(, 1).Formula = "=IF([@[معادلة الرصيد]]=""يستحق"",$O$1+[@[معالجة الرصيد]],0)" .Offset(, 6).Resize(, 1).Formula = "=[@[الرصيد المرحل]]+[@[رصيد 2023]]" .Offset(, 7).Resize(, 1).Formula = "=(COUNTIFS('يومية الحضور والإنصراف'!$A:$A,$A3,'يومية الحضور والإنصراف'!$H:$H,""أجازة"")+(COUNTIFS('يومية الحضور والإنصراف'!$A:$A,$A3,'يومية الحضور والإنصراف'!$H:$H,""أجازة مجمعة"")))" .Offset(, 8).Resize(, 1).Formula = "=(COUNTIFS('يومية الحضور والإنصراف'!$A:$A,$A4,'يومية الحضور والإنصراف'!$H:$H,""أجازة عارضة""))" .Offset(, 9).Resize(, 1).Formula = "=IF(E3=""يستحق"",$N$1-[@[ عارضة]],0)" .Offset(, 10).Resize(, 1).Formula = "=(([@[إجمالي الرصيد المستحق]]-([@[ سنوي]]+[@[ عارضة]]+[@[تسوية نقدي]])))-[@[باقي رصيد العارضة]]" .Offset(, 11).Resize(, 1).Formula = "=([@[باقي رصيد السنوي ]]+[@[باقي رصيد العارضة]])" With .Resize(, 12) .Value = .Value End With End With End Sub

@saad 77 @saad alyousif @فوزى فوزى @مصطفى محمود مصطفى @mohameddeela @فارس حسن3

وعليكم السلام ورحمة الله تعالى وبركاته تقضل استاد فوزي ربما هدا ما تقصد Const MyWidth As Single = 80 Const MyHight As Single = 20 Private Sub TEST1() Dim WS As Range Dim Lf As Double, Tp As Double Dim ContColmn As Integer, r As Integer, c As Integer Set WS = Range("A3:I17") ContColmn = WS.Columns.Count For r = 1 To WS.Rows.Count l = 0 Lf = Me.Frame1.Width - 100 For c = 1 To ContColmn Lf = Lf - WS.Columns(c).Width With Me.Frame1.Controls.Add("Forms.Label.1") .BorderStyle = 1 .Move Lf, Tp, MyWidth, MyHight .Width = WS.Columns(c).Width Call TEST(.Name, WS.Cells(r, c)) End With Next Tp = Tp + MyHight c = 0 Next Set X = Nothing End Sub Private Sub TEST(iName As String, MyCel As Range) With Me.Controls(iName) .BackColor = MyCel.Interior.Color .Caption = MyCel.Text .TextAlign = 2 With .Font .Name = MyCel.Font.Name .Bold = True .Size = MyCel.Font.Size End With End With End Sub Private Sub UserForm_Initialize() Me.Frame1.SpecialEffect = 0 TEST1 End Sub عرض النتائج فى الفورم_1.xlsm

أحسنت استاذ وجيه بارك الله فيك وزادك الله من فضله .. عمل ممتاز

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

بعد اذن استاذنا الفاضل والقدير الاستاذ ضاحى ورغبة استاذى gamalin وطلبه للملف استاذن من الاستاذ ضاحى غريب ان اعطيه الملف بعد ما اصبح يعمل معى ZAD IPTV Subscription.xlsm

وعليكم السلام -على الرغم من كثرة طلباتك !!! - تفضل لك ما طلبت جدول 1المباريات.xlsx

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

المرفق به فورم يحتوي على عدد 2 ليست بوكس احدهما لجلب اسماء الاوراق الموجودة في ملف الاكسيل يوجد ازرار تمكنك من ترحيل اسماء الاوراق التي تريد طباعتها او حفظها إلى الليست بوكس الاخر ومن ثم الضغط على زر الطباعة او الحفظ يمكنك اكتشاف الامر عمليا حمل المرفق وشاهد Print and Save As pdf Using ListBox in a UserForm.rar

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

السلام عليكم اعداد تقرير من نطاق معين اتوماتيكيا عن طريق فورم لاختيار رؤوس الاعمدة التي تريده في التقرير ما عليك سوى تغيير اسم الورقة والعمود الذي يعين آخر صف في النطاق والنطاق هنا: Private Sub kh_MyRngSet() Dim Last As Long '======================== ' تعيين النطاق ويشمل رؤوس الاعمدة With Sheets("قاعدة البيانات") Last = .Range("C" & .Rows.Count).End(xlUp).Row Set MyRng = .Range("A2:Z" & Last) End With '======================== Num = MyRng.Columns.Count End Sub وتعيين اول صف في ورقة التقرير هنا: '======================== ' اول صف للتقرير Const iRow As Integer = 3 '======================== خبور خير اعداد تقرير حسب اختيار الاعمدة اتوماتيكيا.rar

اخى الفاضل اذهب الى ملف File خيارات Options خيارات متقدمة Advanced وانزل قليلا للاسفل وتأكد من وجود علامة صح بجانب اظهار كافة النوافذ في شريط المهام Show All Windows In Taskbar .. ان لم تكن موجودة قم بوضعها كما في الصورة المرفقة .. جرب واعلمنا بالنتيجة تحياتي

السلام عليكم الشكر واصل لاخي ابوحنين تم فرز البيانات حسب عمود الاسم بعد مسح الخلايا التي لا توجد فيها معادلات Sub trheel() Dim cel As Range Dim Lr As Long, Lrr As Long, R As Long, i As Long, iCont As Long With Sheets("البيانات") Lr = .Cells(Rows.Count, "B").End(xlUp).Row iCont = WorksheetFunction.Max(.Range("A3").Resize(Lr)) Lrr = Cells(Rows.Count, "D").End(xlUp).Row For R = 3 To Lrr If Cells(R, "O").Value = "ناجح" Then i = i + 1 .Cells(Lr + i, "A").Value = iCont + i .Cells(Lr + i, "B").Resize(1, 13).Value = Cells(R, "B").Resize(1, 13).Value .Cells(Lr + i, "O").Value = [I1] .Cells(Lr + i, "P").Value = [M1] If cel Is Nothing Then Set cel = Cells(R, "A").Resize(1, 13) Else Set cel = Union(cel, Cells(R, "A").Resize(1, 13)) End If Next End With If i Then On Error Resume Next cel.SpecialCells(xlCellTypeConstants).ClearContents On Error GoTo 0 With Range("A3:M" & Lrr) .Sort .Columns(4), xlAscending End With End If Set cel = Nothing End Sub تحياتي