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

وعليكم السلام 🙂 عملت تغيير بسيط في الكود السابق: myTotal_Page_Number = 5 Do until myPage_Number = myTotal_Page_Number myPage_Number = myPage_Number + 1 Docmd.openreport" " acviewnormal Loop اذهب الى اي وحدة نمطية عندك ، واذا ما عندك ، اعمل واحدة ، واكتب التالي في اعلى الوحدة النمطية: Option Compare Database Option Explicit اكتب التالي تحت السطر او السطرين اعلاه public myPage_Number as integer public myTotal_Page_Number as integer وفي التقرير اعمل حقلين جدد لترقيم الصفحات: حقل رقم الصفحة التي يتم طباعتها الآن ، وفي مصدر بيانات الحقل اكتب: myPage_Number= حقل مجموع عدد الصفحات التي يتم طباعتها الآن ، وفي مصدر بيانات الحقل اكتب: myTotal_Page_Number= جعفر

المشكلة كانت في عدم ترتيب الصفوف حسب الــ Grade تم معالجة الأمر بتعديل الكود بحيث يعمل في كل الاحتمالات (ترتيب او عدم الترتيب) 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, a% Dim k As Byte, m As Byte Dim Cret1, Cret2 Dim Col As Object, Dic As Object Dim Lt, t%, Ar_count, y, kk% Dim Mn, A_arr() 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) Ar_count = My_rg.Areas.Count For y = 2 To Ar_count For kk = 1 To My_rg.Areas(y).Rows.Count ReDim Preserve A_arr(a) A_arr(a) = _ My_rg.Areas(y).Cells(kk) a = a + 1 Next kk Next y If a = 0 Then Exit Sub For i = LBound(A_arr) To UBound(A_arr) If IsNumeric(A_arr(i)) Then Col.Add Val(A_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 m = 8: t = 0 Do Until t = Dic.Count + 1 Set F_rg = My_rg.Find(Dic.keys()(t) _ , lookat:=1) If Not F_rg Is Nothing Then 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 End If t = t + 1 If t = Dic.Count Then Exit Do Loop If sh.FilterMode Then My_rg.AutoFilter End If Application.ScreenUpdating = True Set sh = Nothing Set My_rg = Nothing: Set F_rg = Nothing Set Col = Nothing: Set Dic = Nothing Erase A_arr End Sub Masry_Super.xlsm

أ.abouelhassan قبل ما تظلم إستيراد البيانات تأكد من شيت الإكسيل ومن رأيي تمسح محتويات الجدول فى البرنامج ثم تدقق فى ملف الاكسيل لأي أخطاء ثم تعيد الاستيراد وكله هيظبط بإذن الله

أ.abouelhassan شكلك مفهمتنيش .. تابع الصور جرب ووافنى بالنتيجة .. اما نشوف اخرتها مع البرنامج ده 🤣

وعليكم السلام اخى واستاذى @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

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

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

تم تصميم برنامج الرائد في إدارة مزارع الأرانب الإصدار الأول: بفضلكم تم الإنتهاء من تصميم هذا البرنامج فالرجاء المساعدة في نشره وترويجه بارك الله فيكم وهذا رابط البرنامج https://mega.nz/file/P8YiRbaR#twAa1EmJYr_t1DB-fj7nXpnqKXuHdSN2K1NR167IORs

أشكرك أستاذ علي فعلا هي المطلوب

خالص تحياتي لشخصكم الكريم كما عهدناكم ... آدام الله عليكم الصحة والعافية

السلام عليكم بدون احداث افتح اي وحدة نمطية عامة ( module) موجودة في البرنامج عندك والصق السطرين في اعلى الصفحة بشرط يكونوا تحت Option Compare Database Option Explicit ويمكن تجد فقط Option Compare Database

انا لم اعمل اي تعديل على القيم فقط عدلت على خصائص مقطع الصفحات

وعليكم السلام-بسيطة اجعل المعادلة هكذا =IF(OR($A2="",$B2=""),"",DATEDIF($A$2,$B$2,"d")) ‫معادلة حساب تاريخين - 1نسخة.xls

السلام عليكم لا اعلم متى تستغني عن ارقام الصفحات ، فوجوده في اكسس لا معنى له وهي سبب المشكلة تفضل تعديل بسيط على مرفق اخي احمد DATA14.rar

تفضل يا سيدي 🙂 With sql .AddNew !PONumber = Me.T7 !MaterialCode = Lsql!code !MaterialName = Lsql!Item !ProductionDate = Me.T6 !Shift = "none" !cons = Lsql!cons !AdditionPercent = Lsql!Remarks !MaterialType = Lsql!Type !OrderQty = Nz(Lsql!cons, 0) * Nz(Me.T3, 0) .Update End With جعفر

تم معالجة الامر على 3 خلايا (اختصار الملف من اكثر من 1000 صف الى حوالي 50) لمعاينة المعادلات يمكنك تكملة الموضوع Ahmad.xlsx

جوابا عن الجزء الأول من السؤال بواسطة استعلام تحديث MZtab.accdb

هل الحقل PONumber او T2 موجود في النموذج المستمر؟ واذا موجود ، هل قيمته تتغير ، اذا الجواب ان قيمته لا تتغير ، اكتب السطر هكذا : !PONumber = me.T7 وبغض النظر عن الحقل اعلاه ، خلينا نشوف اذا الكود شغال صح اصلا ، وعلشان الحبايب ، هذه الحقول اللي فيها مشكلة ، اوقف عمل سطرها مؤقتا 🙂

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

لا T1 مو صحيح ، وانما الصحيح هو item ، يعني جرب: !MaterialName = Lsql!Item

بالتوفيق اخي حسان الحقيقة لم اقم بتنصيب البرنامج ولكن قمت بالاطلاع على محتويات الملف التنفيذي ولدي بعض الملاحظات اتمنى تتقبلها بصدر رحب البرنامج تجريبي لمدة 15 يوم او 15 تسجيل دخول البرنامج يقوم بتغيير دقة الشاشة الى 1024 * 768 وهي دقة منخفضة جدا بالنسبة لقاعدة البيانات استخدمت تسميات عربية لكائنات القاعدة واسماء طويلة والبعض منها متداخل وغير واضح ايضا حقول الجدول باسماء عربية والبعض منها مركب ولم تستخدم ( _ ) للفصل بين الاسماء المركبة لم يتم استخدام البادئة الصحيحة لاسماء الكائنات في جميع الاحوال جهد كبير ومقدر مع تمنياتي لك بالتوفيق وان يجد برنامجك القبول والانتشار المناسب واتمنى تشاهد الموضوع 👇 يحتوى على نصائح مفيدة

جرب هذا الملف my_user.xlsm

لا يمكنك حذف هذا ، فهو الاساس !! مو اسم الحقل ، وانما اسم مصدر بيانات الحقل

الاسماء اللي على يمين علامة = ، رجاء تأخذ اسمها الصحيح من النموذج المستمر

نعم كل طرق تؤدي الى روما لكن هنا اختصرنا الموضوع بملف 1 كيلو بايت مايكروا لو بيدها اجبرت المستخدمين على اصدار 365 واستفادت من سعر الاشتراك الشهري وخصوصا انه لايوجد برنامج منافس للاكسس للاعمال الشخصية والصغيرة

شكرا اخوي خالد 🙂 هي نفس الطريقة التي اتبعها في برنامج ونفسها التي استعملتها ، ولكن من داخل الاكسس (استخدمت اسماء متغيرات من البرنامج) : . ويبقى السؤال طافيا ، لماذا !! للعلم ، حاولت تتبع هذه النقطة وفرأت المزيد من موقع مايكروسوفت وبالبحث ، واتضح بأنه في احد الحالات ، انزلت المايكروسوفت إضافة/تحديث في الاكسس في حقل تاريخ من نوع Extended ليماشي DateTime2 الذي في SQL Server ، وبعد ان حصل الكثير على نفس رسالة الخطأ "تحتاج الى نسخة احدث" ، قالت مايكروسوفت بأنها انزلت التحديث بدون تريث ، فلهذا ازالت هذا التحديث ، واصبحت البرامج تعمل بطريقة عادية. ولكن الملفت للنظر هو ، ان مايكروسوفت لم تعمل ملف تحديث للكمبيوترات ، وانما اشتغلت البرامج بطريقة صحيحة 😮!! ويا غافل لك الله 🙂 جعفر

جرب هذه المعادلة =IFERROR(LOOKUP(1,0/(Sheet1!$B:$B=$G5)/(Sheet1!$C:$C=$C5),Sheet1!$E:$E),"") m h1.xlsb

وعليكم السلام-يمكنك استخدام هذه المعادلة =IF($N5="","",OFFSET($B$4,MATCH($O5,$B$5:$B$13,0),MATCH($N5,$C$4:$L$4,0))) اكثر من شرط في الدالة1.xlsx

اشكرك جزيل الشكر أخي احمد .. نعم هذا هو بالضبط ماكنت ابحث عنه .. الموضوع غريب نوعا ما حيث ان الكود دائما ماكان يعطيني خطأ حتى بالصيغة التي تفضلت بها خصوصا بعد اضافته الى برنامجي الرئيسي وبعد البحث والتمحيص اكتشفت ان سبب الخطأ هو باستخدام Deftype statement في بداية الـ Modules كالتالي Option Compare Database Option Explicit DefLng A-Z

بارك الله فيك

السلام عليكم اخوانى محاولتى على قدر معرفتى وان شاء الله يشاركنا اخواننا واساتذتنا جزاهم الله خيرا قمت بانشاء استعلام ثم قمت بادراج المعادلات التى بحقلى مكعب وجمله بداخل الاستعلام وقمت بتصفيه الاستعلام بناء على رقم الفاتوره ثم قمت باستخدام دوال التجميع dcount للعدد و Dsum للاجمالايات a1.accdb

اخوي ابوعبدالله_1972 الله يشفيك ان شاء الله 🙂 العنوان ، مخالف ومناشدتك مساعدة عضو معين ، مخالف وسؤالك لأكثر من طلب ، مخالف فرجاء اقرأ قوانين المنتدى ، وافتح موضوع جديد تأخذ في الاعتبار النقاط اعلاه 🙂 يُغلق جعفر

جرب هذا الكود 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

وعليكم السلام 🙂 اذا كانت العملية الحسابية بين حقول في النموذج ، فلا داعي لإستعمال المتغير ، مثلا : if me.txt1 > me.txt2 then me.txt1= me.txt2 * 50 endif او me.txt1= me.txt1 + (me.txt2 * 50 / 5) او تاريخ بكرة me.Tomorrow= date() + 1 . بينما اذا اردت ان تحتفظ بقيمة معينه مؤقتا في الكود ، ثم تحتاج للقيمة مرة اخرى ، فالحفظ يكون في متغير ، مثلا : هذا مسار الصورة Application.currentproject.path & "\images\" & me.Project_Name & "\" & me.item_Number & ".jpg" فبدل ان استخدم هذا السطر الطويل ، وكل مرة يضطر الاكسس لقراءة قيم الحقول من النموذج if dir(Application.currentproject.path & "\images\" & me.Project_Name & "\" & me.item_Number & ".jpg")="" then me.img.picture = Application.currentproject.path & "\images\" & me.Project_Name & "\" & me.item_Number & ".jpg" else msgbox "لم يتم الحصول على الصورة في المسار التالي" & vbcrlf & _ Application.currentproject.path & "\images\" & me.Project_Name & "\" & me.item_Number & ".jpg" me.img.picture="" me.img2.picture = Application.currentproject.path & "\images\" & me.Project_Name & "\" & me.item_Number & ".jpg" end if نستطيع اعطاء المسار الى متغير ، ثم نستعمل المتغير وبما ان المسار عبارة عن نص dim myFile as string myFile = Application.currentproject.path & "\images\" & me.Project_Name & "\" & me.item_Number & ".jpg" if dir(myFile)="" then me.img.picture = myFile else msgbox "لم يتم الحصول على الصورة في المسار التالي" & vbcrlf & myFile me.img.picture="" me.img2.picture = myFile end if جعفر

السلام عليكم ورحمة الله وبركاته بعد اذن استاذنا عصام ربيع وضعت لك كود خلف زر لاستيراد البيانات من فورم الأصناف كما بالصورة اضغط علي الزر وانظر النتيجة ولا تنسانا من دعوة بظهر الغيب ملاحظات: 1- اجعل شيت الاكسل في نفس مجلد البرنامج 2- عدل اسم العمود ipage_ID في شيت الاكسل ليتناسب مع اسم العمود بالجدول ليصبح ipage فقط 3- لا تنزعج من رسالة تأكيد الاستيراد للبيانات ImportFromExcel.rar

ما العمل وانت تقومين بتشكيل ملف مع صفحات غير منتظمة من حيث النتسيق في الصورة الرقم المستندى في عامود (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

اخر ما بمكنني عمله 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, 3).Resize(, Col - 2)) = 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, 2).Resize(, Col - 1). _ 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).Resize(, 6).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:f" & 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 الملف مرفق لمسح محتويات الشيتات بعد الترحيل ازالة كلمة Rem من هذا السطر من الكود (الصورة) Yara_WITH DEL_file.xlsm

اذن هنا مربط الفرس !!

لا اكتب اي كود يتضمن اللغة الغربية (لحسن نسخه ولصقه) لذلك قمت بتغيير اسماء الصفحات التي يعمل عليها الكود الى اللغة الأجنبية (الصفحات الاخرى تم اخفائها وليس حذفها) Option Explicit Sub Get_Data() Dim arr As Variant, itm Dim x As Boolean Dim sh As Worksheet, My_sheet As Worksheet Dim ro%, Col%, m%, k%, i% Dim F_rg As Range arr = Array("S_1", "S_2", "S_3") m = 2 Main.Range("A1").CurrentRegion.Offset(1).Clear For Each itm In arr Set sh = Sheets(itm) ro = sh.Cells(Rows.Count, 1).End(3).Row Col = sh.Cells(1, Columns.Count).End(1).Column For i = 2 To ro Main.Cells(m, 2).Resize(, 2).Value = _ sh.Cells(i, 1).Resize(, 2).Value Set F_rg = sh.Cells(i, 2).Resize(, Col - 1). _ Find("*", after:=sh.Cells(i, 3)) If Not F_rg Is Nothing And F_rg.Column <= Col Then With Main.Cells(m, 4) .Value = F_rg .Offset(, 1) = sh.Name .Offset(, 2) = sh.Cells(1, F_rg.Column) End With End If m = m + 1 Next i Next itm If m > 2 Then With Main.Range("a2:f" & m) .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 14 .InsertIndent 1 .Interior.ColorIndex = 35 .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 & ")" End With End With End If End Sub Yara.xlsm

أولا: كان من الأنسب لو أدرجت عدد من الأسماء لمحاكاة الواقع ثانيا: بما أن الرقم الوطني موجود، فلا داعي للبحث بالاسم لتجنب الاختلاف بين الملفين كما ذكرت، فالأرقام تحسم الموضوع بكل دقة ، ولم تذكر أن الارقام غير دقيقة مرفق المطلوب أسماء.xlsx

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