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

أخي الكريم الدهشوري قمت بالبحث عن الدالة المعرفة وقمت بعمل معادلة لتناسب طلبك .. أرجو أن يفي الملف المرفق بالغرض إن شاء الله Days Tafkeet.rar

بعد اذن الاخوة تفضل هذا الكود Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 3 Then On Error Resume Next Dim myrg As Range Set myrg = ورقة1.Range("A1:B100") Target.Offset(, 1).Value = "" Target.Offset(, 1).Value = Application.WorksheetFunction.VLookup(Target.Text, myrg, 2, 0) End If End Sub اما بخصوص كود اخي الغالي ابو البراء قم بتعديل من Sheet1 الى ورقة 1 داخل الكود حسب الموجود لديك

ياما في الجراب يا حاوي .. كله بفضل الله عزوجل .. لدي مكتبة تجميعية لعدد كبير من الأكواد أطوعها في تلبية الطلبات بحيث تلبي جميع الاحتياجات وافر تقديري واحترامي

وإثراءً للموضوع هذا كود آخر كنت قد جهزته وانتظرت أن يصل أخي وحبيبي سليم لخط النهاية قبلي .. الكود يوضع في موديول عادي Sub TransferData() Dim DictPerson As Object, DictSheet As Object, rng As Range, mtx(), isFound As Boolean Dim I As Long, v1 As Variant, v2 As Variant Application.ScreenUpdating = False Set rng = Sheets("Tafasil").Range("A1:O" & Sheets("Tafasil").Cells(Rows.Count, "O").End(xlUp).Row) mtx = rng.Value Set DictPerson = CreateObject("Scripting.Dictionary") For I = 2 To UBound(mtx, 1) If Not DictPerson.Exists(mtx(I, 15)) Then DictPerson.Add mtx(I, 15), mtx(I, 15) Next I Set DictSheet = CreateObject("Scripting.Dictionary") For I = 1 To Worksheets.Count If Not DictSheet.Exists(Worksheets(I).Name) Then DictSheet.Add Worksheets(I).Name, Worksheets(I).Name Next I DictSheet.Remove ("Tafasil") For Each v1 In DictPerson isFound = False For Each v2 In DictSheet If v1 = v2 Then isFound = True Exit For End If Next v2 If Not isFound Then If MsgBox(v1 & " Does Not Exist." & vbCrLf & "Create This Sheet ? ", vbOKCancel) = vbOK Then Worksheets.Add After:=Sheets("Tafasil") ActiveSheet.Name = v1 ActiveSheet.DisplayRightToLeft = True DictSheet.Add v1, v1 End If End If Next v1 For Each v1 In DictSheet Sheets(v1).Cells.Clear Sheets(v1).Range("A1").Resize(1, 4).Value = Array("الاسم", "الرقم", "الفرق", "الموقع") rng.AutoFilter field:=15, Criteria1:=v1 With rng.Offset(1) .Columns("A:B").SpecialCells(xlCellTypeVisible).Copy: Sheets(v1).Range("A2").PasteSpecial xlPasteValues .Columns(5).SpecialCells(xlCellTypeVisible).Copy: Sheets(v1).Range("C2").PasteSpecial xlPasteValues .Columns(15).SpecialCells(xlCellTypeVisible).Copy: Sheets(v1).Range("D2").PasteSpecial xlPasteValues End With With Sheets(v1) .Range("A1").CurrentRegion.Borders.Value = 1 .Range("A1").Resize(1, 4).Font.Bold = True .Cells.RowHeight = 19 .Cells.HorizontalAlignment = xlCenter: .Cells.VerticalAlignment = xlCenter .Columns(1).ColumnWidth = 18: .Columns("B:C").ColumnWidth = 10: .Columns(4).ColumnWidth = 13 End With Next v1 rng.AutoFilter Application.ScreenUpdating = True MsgBox "Done...", 64 End Sub تقبل تحياتي

بارك الله فيك أخي الغالي سليم كم أعشق حلولك الممتازة والرائعة تقبل وافر تقديري واحترامي

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

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

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

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

الاخ ياسر خليل أبو البراء المرفق ليس به جديد سوي الاضافة التي اشرت اليها اما ملف دالة التفقيط الخاصة بالأخ هادي لدي ملف مجمع للمجموعة كامله التفقيط ###.rar

مرحبا بعد إذن أخي ياسر يمكن ان نستعمل الدالة التالية في الخلية D2 ونسحبها للأسفل =IFERROR(VLOOKUP(C2;المسافة!$A$1:$B$500;2;0);"")

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

وعليكم السلام أخي الكريم محمد جرب الكود التالي في حدث ورقة العمل المسماة "الجدول" كليك يمين على اسم ورقة العمل "الجدول" ثم اختر View Code والصق الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) If Target.Row > 2 And Target.Column = 3 Then Application.EnableEvents = False Dim iRow iRow = Application.Match(Target.Value, Sheet1.Columns(1), 0) If IsNumeric(iRow) Then Target.Offset(, 1).Value = Sheet1.Cells(iRow, "B").Value End If Application.EnableEvents = True End If End Sub تقبل تحياتي

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

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

جميل ورائع أخي الحبيب سليم كمل جميلك .. عند عدم وجود ورقة عمل يتم إنشاء ورقة عمل جديدة ..هلا خيرت المستخدم إذا كان يريد ورقة العمل أم لا؟ وأمر آخر يتم نسخ كافة عناوين الحقول عند إنشاء ورقة عمل جديدة (لاحظ هذه النقطة) ملحوظة أخرى : إذا قمت بحذف كل أوراق العمل والإبقاء على الورقة الرئيسية ثم تنفيذ الكود لا يقوم بإنشاء أوراق العمل بشكل صحيح ويحدث خلل كبير .. تقبل وافر تقديري واحترامي

بارك الله فيك أخي سليم وجد حل عن طريق هذه الدالة =MOD(A1;1)=0 باستخدام طريقة التنسيق الشرطي وطبقتها على العامود A فقمت أولا بتنسيق العامود بالطريقة الطبيعية ووضع تنسيق عملة و 2 منزلة عشرية ومن ثم وضعت تنسيق شرطي عندما يتحقق هذا الشرط =MOD(A1;1)=0 يكون التنسيق عملة و0 عدد المنازل العشرية

مشكور اخي ياسر على هذه الملاحظة القيمة تم التعديل على الكود المذكور تم التعديل مرة اخرى بواسطة هذا الكود Sub CreateSheets() Dim ws As Worksheet Dim K As Range Dim ListSh As Range Application.ScreenUpdating = False With Worksheets("tafasil") Set ListSh = .Range("o2:o" & .Cells(.Rows.Count, "o").End(xlUp).Row) End With On Error Resume Next For Each K In ListSh Worksheets("tafasil").Activate If Len(Trim(K.Value)) > 0 Then y = Worksheets(Trim(K.Value)).Name t = Application.CountIf(Range("o2:o" & K.Row), Trim(K.Value)) If IsEmpty(y) And t = 1 Then Worksheets.add(After:=Worksheets(Worksheets.Count)).Name = K.Value ActiveSheet.Range("a1:d1") = Array("الاسم", "الرقم", "الفرق", "الموقع") '============================================ End If y = Empty End If Next K Application.ScreenUpdating = True Worksheets("tafasil").Select End Sub و تغيير مسح البيانات الى هذا الكود Sub del_data() For mh = 2 To Sheets.Count Sheets(mh).Range("A2:d5000").ClearContents Next Sheets("tafasil").Select Range("a2").Select End Sub و الكود النهائي الى هذا الكود Sub AddValues() Dim My_sheet As Worksheet Dim i As Single '============================= Application.ScreenUpdating = False CreateSheets answer = MsgBox("هل تريد مسح البيانات في الاوراق الباقية أولاً ", vbQuestion + vbYesNo + vbMsgBoxRtlReading) If answer = 6 Then del_data lr_MAIN = Sheets("tafasil").Cells(Rows.Count, 1).End(3).Row If lr_MAIN < 2 Then lr_MAIN = 2 For K = 2 To lr_MAIN '========================================== On Error Resume Next Set My_sheet = Sheets("" & Sheets("tafasil").Range("O" & K)) If Sheets("tafasil").Range("O" & K) = "" Then GoTo 1 '========================================== With My_sheet i = .Range("A" & Rows.Count).End(xlUp).Row + 1 .Range("A" & i) = Sheets("tafasil").Range("A" & K) .Range("b" & i) = Sheets("tafasil").Range("b" & K) .Range("c" & i) = Sheets("tafasil").Range("e" & K) .Range("d" & i) = Sheets("tafasil").Range("O" & K) .Range("a2").Select End With '========================================== 1: Next Application.ScreenUpdating = True Sheets("tafasil").Range("a1").Select End Sub ليصبح الشكل النهائي للملف هكذا الترحيل حسب الموقعsalim2.rar

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

جزاك الله كل خير ........... واليك بعض الكلمات التى لا تصف ولو جزء بسيط من عبقريتك لكل مبدع إنجـــــــــاز ...... ولكل شكر قصيده ....... ولكل مقام مقال . ولكل نجاح شكر وتقدير ...... فجزيل الشكر اهدية إليك ...."" يا استاذ / ياســـر """ ... ورب العرش يحميك . كلمات الثناء لا توفيك حقك .... شكراً لك على عطائك ... تتسابق الكلمات وتتزاحم العبارات لتنظم عقد الشكر الذى لا يستحقه إلا أنت إليك يا من كان له قدم السبق في ركب العلم والتعليم إليك يا من بذلت ولم تنظر العطاء إليك أهدي عبارات الشكر والتقدير ... (( أستاذنا القدير / ياسر ))

شكرا يا زعيم انت دائما في الموعد ،، ربنا يبارك فيك.

هو انت فين مخبي الحاجات دي كلها

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

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

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

تم التعديل مرة ثالثة الترحيل حسب الموقعsalim3.rar

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

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

1-انسخ هذه المعادلة الى الخلية J9 2- اضغط (Ctrl+Shift+Enter) 3-اسحب المعادلة الى باقي الصفوف =INDEX($C$2:$C$12,MATCH(H9&I9,$A$2:$A$12&$B$2:$B$12,0))

ا / عمر ا / ياسر الف شكر علي ذوقك الرفيع، وصبرك على كثرة طلباتي الحمد لله الملف اصبح افضل مما كنت اتمني كل الشكر والامتنان لك وذادك الله علم

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

ضع العبارة بعد الحلقة التكرارية وجرب بنفسك ..!!

ضع السطر التالي قبل سطر الخطأ On Error Resume Next

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

وهذا شرح توضيحي

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

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

مبروك اخينا الكريم الوزير :: مثابر ومتابع ... لك مني الف تحية وتقدير

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

انا ساشارك مجاراة مع الموضوع الاصلي حتى لو انه منطقيا فقط في حالة ان الترقيم لن يتعدى خمس خانات بعد كود السنة اي فرضا لو وصل الترقيم 1399999 اي هناك اكثر من تسعة وتسعون الف وتسعمائة وتسع وتسعون سجل في السنة سنة 2013 فماهي السياسة في الزيادة . فلو استمرينا باضافة 1 سيكون السجل التالي يبدا 14 ونحن مازلنا في نفس السنة . ولكن حسب رأي الاخ محمد سلامة بانه لن يحصل خلال السنة فهذا الكود سيعمل وبدون اللاحقة s . لكي يضل المحتوى نفس الموضوع. Private Sub Form_BeforeInsert(Cancel As Integer) If Right(Year(Date), 2) > Left(DMax("ID", "tbl1"), 2) Then xNext = Right(Year(Date), 2) & "00001" Else xNext = DMax("ID", "tbl1") + 1 End If ID = xNext End Sub

السلام عليكم جرب الرفق حذف وتعديل اسم عميل.rar هل بهذه الطريقة

مشكور اخي ياسر على هذه الملاحظة القيمة تم التعديل على الكود المذكور الترحيل حسب الموقعsalim1.rar

جرب هذا الماكرو يعمل فقط على العامود A يمكن التغيير الى اي عامود (اعمدة تشاء) Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 1 And IsNumeric(Target) Then On Error Resume Next If Int(Target) = Target Then Target.NumberFormat = Selection.NumberFormat = "\$ 0" If Int(Target) <> Target Then Target.NumberFormat = "\$ 0.00" End If End Sub

وعليكم السلام أخي الكريم أبو يحيى حدد الخلايا المراد تغيير التنسيق لها ثم كليك يمين ثم اختر Format Cells ثم اختر أول خيار في القائمة في جهة اليسار والمسمى General

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

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

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

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

السلام عليكم اخي المكرم / عادل ----------------حفظه الله من الافضل تسمية النطاق (kh_test_1) بعدد الاعمدة التي تشمله ( لم يتم تغييره في مرفقك) و تضيف متغير جديد في الكود بعدد الاعمدة في النطاق و تستخدم هذا المتغير بدلا من اضافة رقم للعمود في الكود ويصبح الكود ثابت ويتم فقط للاستخدام تحديد النطاق في الورقة مثلا : MyColumns = .Columns.Count اليك الكود : Private Sub Worksheet_Change(ByVal Target As range) Dim MyRows As Integer, MyColumns As Integer, MyRange As range, MyRange1 As range On Error GoTo 1 With range("kh_test_1") MyRows = .Rows.Count - 1 MyColumns = .Columns.Count Set MyRange = .range(cells(MyRows, 1), cells(MyRows, MyColumns)) If Not Intersect(Target.cells(1, 1), MyRange.cells) Is Nothing _ And Target.Value <> "" Then MyRange.EntireRow.Insert Set MyRange1 = .range(cells(MyRows, 1), cells(MyRows, MyColumns)) MyRange1.Value = MyRange.Value MyRange.ClearContents End If End With 1 End Sub ==================================================== و هناك اضافة جديدة لو تريدها في حالة اردت حذف صف معين تمسح بيانات خلية الاسم فيحذف الصف تلقائيا باستخدام هذا الكود: Private Sub Worksheet_Change(ByVal Target As Range) Dim MyRows As Integer, MyRange As Range, MyRange1 As Range, MyCells As Range On Error GoTo 1 With Range("kh_test_1") MyRows = .Rows.Count - 1 Set MyRange = .Range(Cells(MyRows, 1), Cells(MyRows, 4)) Set MyCells = .Range(Cells(1, 1), Cells(MyRows - 1, 1)) If Not Intersect(Target.Cells(1, 1), MyRange.Cells) Is Nothing _ And Target.Value <> "" Then MyRange.EntireRow.Insert Set MyRange1 = .Range(Cells(MyRows, 1), Cells(MyRows, 4)) MyRange1.Value = MyRange.Value MyRange.ClearContents End If End With If Not Intersect(Target.Cells(1, 1), MyCells.Cells) Is Nothing Then If Target.Value = "" Then Target.EntireRow.Delete End If 1 End Sub سارفق الملف لاحقا Dinamic_Lable1.rar

السلام عليكم تواصلاً للفكرة الجميلة للاخ عادل تفضلوا المرفق تحياتي لجميع المشاركين حفظهم الله ______________.rar