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

السلام عليكم عيدكم مبارك بالمرفق كود يقوم نيابة عنك بإكمال البيان الذي تكتبه في عمود معين بورقة عمل استناداً لمجال معين بورقة عمل آخري منفصلة. كيف ؟؟؟؟ الشرح : 1- قم بتدوين البيانات التي تريدها في المجال المسمى AutoCompleteText ضمن العمود A بالورقة المسماة Source data يجب أن تكون البيانات المدخلة غير مكررة . 2- الان انتقل إلى العمود A بالورقة المسماة Test sheet وقم بكتابة الأحرف الأولى المميزة والفريدة لأحد البيانات التي دونتها بالمجال السابق ثم اضغط Enter ،، سيكمل الكود البيان الذي كتبته سلفاً ،،، على سبيل المثال : اكتب حرف Z ثم اضغط Enter ستكون النتيجة في الخلية ZIAD ALI - لأنه النص الوحيد الذي يبدأ بالحرف Z ،،، واذكر بأنه ممكن أن تقوم بزيادة عدد الأعمدة التي ترغب أن يتم فيها عملية استرجاع البيانات بالصفحة المسماة Test sheet عن طريقة التعديل في الكود أرجو أن يكون المرفق مفيد للجميع ،،، ولكم كل الود والتحية. الاكمال التلقائي للبيانات.rar

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

وعليكم السلام ورحمة الله تعالى وبركاته بعد ادن الاخ @abouelhassan بما انك ترغب بتنفيد المعادلات على شكل كود اليك حل اخر رغم انني لا اعلم ما هي الطريقة المطلوبة لتنفيده Sub sheets_arrformula() 'Execute On All Worksheets Dim wsName As Worksheet, desWS As Worksheet Dim lr As Long, lige As Long Dim ws As Worksheet: Set ws = Sheets("بيانات رئيسية") For Each wsName In ThisWorkbook.Worksheets If wsName.Name Like "*-JAN" Then 'في حالة اظافة اوراق اخرى للمصنف 'Example February March.......... 1-Feb ,2-Feb.......1-Mar ,2-Mar 'If wsName.Name Like "*-*" Then With Application .ScreenUpdating = False .Calculation = xlManual Set desWS = ThisWorkbook.Sheets(wsName.Name) lr = ws.Columns("A:D").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set a = ws.Range("A2:A" & lr): Set b = ws.Range("B2:B" & lr) Set c = ws.Range("C2:C" & lr): Set d = ws.Range("D2:D" & lr) f = ws.Name lige = desWS.Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row - 1 desWS.Range("B2:C" & lige).ClearContents With desWS.Range("B2:B" & lige) .Formula2 = "=IFERROR(INDEX('" & f & "'!" & c.Address & ",MATCH(1,(E$1 ='" & f & "'!" & a.Address & ")*(A2 ='" & f & "'!" & b.Address & "),0)),"""")" .Value = .Value With desWS.Range("C2:C" & lige) .Formula2 = "=IF($B2<>"""",SUMIFS('" & f & "'!" & d.Address & ",'" & f & "'!" & a.Address & ",""=""&$E$1,'" & f & "'!" & c.Address & ",""=""&$B2,'" & f & "'!" & b.Address & ",a2),"""")" .Value = .Value End With End With .ScreenUpdating = True .Calculation = xlAutomatic End With End If Next wsName End Sub ولتنفيد الكود على الورقة النشطة Sub Test2() 'Execute On the Active Worksheet Dim lr As Long, lige As Long Dim ws As Worksheet: Set ws = Sheets("بيانات رئيسية") Dim desWS As Worksheet: Set desWS = ActiveSheet With Application .ScreenUpdating = False .Calculation = xlManual lr = ws.Columns("A:D").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row f = ws.Name Set a = ws.Range("A2:A" & lr): Set b = ws.Range("B2:B" & lr) Set c = ws.Range("C2:C" & lr): Set d = ws.Range("D2:D" & lr) If desWS.Name <> f Then lr = ws.Columns("A:D").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set a = ws.Range("A2:A" & lr): Set b = ws.Range("B2:B" & lr) Set c = ws.Range("C2:C" & lr): Set d = ws.Range("D2:D" & lr) f = ws.Name lige = desWS.Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row - 1 desWS.Range("B2:C" & lige).ClearContents With desWS.Range("B2:B" & lige) .Formula2 = "=IFERROR(INDEX('" & f & "'!" & c.Address & ",MATCH(1,(E$1 ='" & f & "'!" & a.Address & ")*(A2 ='" & f & "'!" & b.Address & "),0)),"""")" .Value = .Value With desWS.Range("C2:C" & lige) .Formula2 = "=IF($B2<>"""",SUMIFS('" & f & "'!" & d.Address & ",'" & f & "'!" & a.Address & ",""=""&$E$1,'" & f & "'!" & c.Address & ",""=""&$B2,'" & f & "'!" & b.Address & ",a2),"""")" .Value = .Value End With End With End If .ScreenUpdating = True .Calculation = xlAutomatic End With End Sub مصنف v2.xlsm

السلام عليكم ورحمة الله وبركاته اخى الفاضل @kkfhvvv تفضل هذا الكود يقوم بتصفية البيانات للثلاث الاعمدة جربه لعله يكون المطلوب Sub RemoveDuplicatesRange() Dim lastRow As Long lastRow = Sheets("البيانات").Cells(Sheets("البيانات").Rows.Count, "O").End(xlUp).Row Sheets("البيانات").Range("O1:Q" & lastRow).Copy Sheets("ارقام").Range("A1").PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False lastRow2 = Sheets("ارقام").Cells(Sheets("ارقام").Rows.Count, "A").End(xlUp).Row Sheets("ارقام").Range("$A$2:$C$" & lastRow2).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo End Sub تقبل تحياتى

انا اسف اخى طريقة عرض طلبك يجب ان تبدأ بالسلام عليكم اخوانى وتكتب طلبك ودعم الطلب بملف عموما جرب واخبرنى يمكنك وضع الكود في وحدة VBA في ملف Excel وسيعمل تلقائيًا بمجرد فتح الملف. إليك الخطوات لوضع الكود وجعله يعمل بشكل تلقائي بدون الحاجة لزر: 1. افتح ملف Excel الذي تريد إضافة الكود إليه. 2. اضغط `Alt` + `F11` لفتح محرر VBA. 3. في القائمة، اختر `Insert` > `Module` لإنشاء وحدة VBA جديدة. 4. الصق الكود في وحدة VBA التي تم إنشاؤها. 5. اضغط `Ctrl` + `S` لحفظ الملف. 6. أغلق محرر VBA. 7. أغلق الملف وأعد فتحه. الآن، سيعمل الكود تلقائيًا عند فتح الملف، حيث سيقوم بحفظ وإغلاق الملف تلقائيًا بعد مرور 5 دقائق من الخمول. Dim StartTimer Const IdleTime = 5 ' وقت الخمول بالدقائق Sub ResetTimer() StartTimer = Now End Sub Sub CheckIdleTime() If (Now - StartTimer) * 24 * 60 > IdleTime Then Application.DisplayAlerts = False ' لعدم عرض رسائل التنبيه ThisWorkbook.Save ' حفظ الملف ThisWorkbook.Close ' إغلاق الملف Application.DisplayAlerts = True End If End Sub Private Sub Workbook_Open() StartTimer = Now Application.OnTime Now + TimeValue("00:01:00"), "CheckIdleTime" ' فحص الوقت كل دقيقة End Sub Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) ResetTimer End Sub Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) ResetTimer End Sub Private Sub Workbook_SheetActivate(ByVal Sh As Object) ResetTimer End

جرب هدا الحل بعد اظافة اليوزرفورم هل يناسبك باسوورد 0 الاعمال الجنوبية userform.xlsm

السلام عليكم هذا الجزء في التصميم تم التطرق اليه في هذا المنتدى ومن يبحث يجد الكثير .. علما اني قد استفدت واخذت من تلك المواضيع فما انا الا ناقل .. والعلم تراكمي ينتقل ويتزايد . وحتى يكون هذا الموضوع مرجع مختصر يتم نقله فقط الى برنامجك .. لذا عملت على اعداد مثال صغير وهو عبارة عن جدول ونموذج ووحدة نمطية ويتم من خلاله رصد التالي : - معرف السجل - اسم الحقل - اسم النموذج - القيمة الأساسية ( قبل التعديل ) - القيمة الجديدة (بعد التعديل ) - اسم المستخدم - تاريخ ووقت التعديل مع امكانية التصفية والبحث بين تاريخين -------------------------------------------------------------- كل ما عليك عمله هو : اولا : نقل الكائنات التالية (جدول/نموذج/وحدة نمطية) الى برنامجك : modAudit / frmAudit / tblAudit ثانيا : اي نموذج في مشروعك ترغب في تتبع التعديلات التي تجري عليه .. فقط الصق فيه هذا الكود في حدث قبل التحديث Private Sub Form_BeforeUpdate(Cancel As Integer) Dim x As Integer If Not IsNull(Me!ID) Then x = WriteAudit(Me, Me!ID) End If End Sub ID يمثل الحقل الفريد داخل النموذج هذا كل شيء ... ---------------------------------------------------------------------------------------------------------------------------------------- نأتي للتفاصيل التي استبعدتها وهي محل النقاش لمن اراد المشاركة . وهي ان الوظيفة تخص تتبع الحقول النصية فقط ، واريد ضم مربع التحرير وكما هو ظاهر في المثال المرفق .. قيمة مربع التحرير "رقمية" والمطلوب اظهار القيمة "النصية" الأساسية ( التي تم تغييرها) ، اظهارها في جدول التتبع اما بالنسبة للقيمة الجديدة فلا اشكال فيها انا عالجت المسألة ووصلت الى حل ولكن بطريقة مطولة فنريد الاستفادة من الخبراء الأفاضل حول هذه النقطة و لأخي @Moosak خاصه تعقيبا على تعليقه هنا ------------------------------------------------------------------------------------ وقد اجاب الاستاذ موسى والاستاذ فادي وأجادا بمثالين احترافيين شاملين فجزاهما الله خيرا 1- المرفق Database2 وهو خاص بالحقول النصية 2- المرفق Track Changes - Moosak شامل الحقول النصية ومربعات التحرير 3- المرفق Database5 شامل الحقول النصية ومربعات التحرير بقي الاختيار لك فاختر ما يناسبك . Track Changes - Moosak.accdb Database2.rar Database5.accdb

فقط المحدد ..... جرب

مشكور جدا اخي الغالي Foksh وصلت وهو المطلوب تحياتي لك يالغالي

من مصدر بيانات النموذج قم باختيار جميع الحقول ، ثم في حقل P ODate اكتب الشرط <Date() ونصيخة من أخيك ( عن تجربة ) استبدل المسافة التي بين المسميات بإشارة _

بالطريقة التي تم فيها عرض السجلات لا اعتقد انه من الممكن تنفيذ فكرتك 😬

من االافضل دكر ما هي النتيجة المتوقعة من الكود جرب ربما هدا ما تقصد Sub HideRowsPrint() Dim i As Long, LastRow As Long Application.ScreenUpdating = False StartRow = 9: LastRow = 300 For i = LastRow To StartRow Step -1 If Cells(i, "C") = "" Then Rows(i).Hidden = True Next i Application.ScreenUpdating = True ActiveSheet.PrintPreview ' ActiveSheet.PrintOut Rows(StartRow & ":" & LastRow).EntireRow.Hidden = False End Sub

تفضل .. fatherAnd Son (1).accdb

اخي الكريم من النموذج Main ، قم باختيار الأب ؛ ثم قم بادخال اسماء الأبناء في حقل SanName واضغط انتر , لا أكثر ولا أقل .

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

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

طيب شوف كدة ..... بداية ... kan_1.accdb

أخي العزيز @سامر محمود جرب هذا التعديلات التي تمت على العلاقات Unif.accdb

ممكن تستخدم الاكواد الاتيه للاخفاء الصفوف واظهارها Sub اخفاء() Dim Cl As Range For Each Cl In Range("a3:a103") If Cl.Value = Range("k2") Then Cl.EntireRow.Hidden = True End If Next Cl End Sub Sub اظهار() Dim Cl As Range For Each Cl In Range("a3:a103") If Cl.Value = Range("k2") Then Cl.EntireRow.Hidden = False End If Next Cl End Sub

سيتم متابعة الفكرة أخي الكريم وإضافتها في التحديثات القادمة ، ولا يهمك أشكرك على ملاحظتك

تفضل محاولة متواضعة fatherAnd Son.accdb

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

Sub SaveAsNewWorkbook() Dim wb As Workbook Dim ws As Worksheet Dim newWb As Workbook Dim newWs As Worksheet Dim folderPath As String Dim clientName As String Dim lastRow As Long ' تحديد المجلد المحتوي على الملف الأصلي folderPath = ThisWorkbook.Path ' اسم العميل (يمكنك تغيير هذا إلى الطريقة التي تريد استخدامها لاستخراج اسم العميل) clientName = "اسم العميل" ' تكوين اسم الملف الجديد newFileName = folderPath & "\" & clientName & ".xlsx" ' نسخ ورقة العمل الحالية إلى مصفوفة Set wb = ThisWorkbook Set ws = wb.ActiveSheet ws.Copy ' حفظ المصفوفة كملف إكسل جديد Set newWb = ActiveWorkbook Set newWs = newWb.Sheets(1) Application.DisplayAlerts = False newWb.SaveAs newFileName, FileFormat:=xlOpenXMLWorkbook Application.DisplayAlerts = True ' تحويل المعادلات في النصف العلوي من الفاتورة إلى قيم lastRow = newWs.Cells(Rows.Count, "A").End(xlUp).Row newWs.Rows("1:" & lastRow \ 2).Value = newWs.Rows("1:" & lastRow \ 2).Value ' إظهار رسالة تأكيد الحفظ MsgBox "تم حفظ الملف كـ" & newFileName, vbInformation, "تم الحفظ" End Sub يرجى ملاحظة أنه يجب استبدال "اسم العميل" بالطريقة التي تريد استخدامها لاستخراج اسم العميل

السلام عليكم استاذ ابوالحسن بعتذر عند مخالفه قواعد المدونه لانى لسه جديد بها وبشكر حضرتك على الاكواد الحمدلله اشتغلت بنسبه 100%

تفضل صديقنا العزيز ,, fatherAnd Son.accdb

أحسنتم بارك الله بكم أخي الكريم عمل رائع ومميز ما شاء الله بارك الله

تمت شكرا جزيلاً

وفقك الله واعانك الف مبروك

جميل جدا جاري التجربة مع جزيل الشكر

ومشاركة في توضيح الفرق بين نوعي المتغيرات المتغير من نوع Integer لتخزن الأرقام الصحيحة ( بدون أعشار ) ، بينما المتغير من نوع Double يستخدم لتخزين الأرقام العشرية ( بما في ذلك الأعشار ) .

المقصود في المتغيرات : السطر اعلاه في اول مثال لك كان Dim i As Integer, x As Integer والصحيح ان يكون : Dim i As Double, x As Double Dbl وليست Dbi اختصار لـــ Double

شكرا جزيلا لكل من اجابني على سؤالي ... جعلها ربي في ميزان حسناتكم ...

وعليكم السلام أخي @Foksh هذا الملف يفيدك kan.accdb

ما شاء الله إلف إلف مبروك ... كفء والله

جرب Function GetCustomerData(customerCode As String, dataSheet As Worksheet) As Variant Dim dataRange As Range Dim result As Variant Set dataRange = dataSheet.Range("A:C") result = Application.WorksheetFunction.Index(dataRange.Columns(3), _ Application.WorksheetFunction.Match(1, (dataRange.Columns(1) = [E1]) * (dataRange.Columns(2) = customerCode), 0)) GetCustomerData = IIf(customerCode = "", "", result) End Function Function GetCustomerTotal(customerCode As String, dataSheet As Worksheet) As Variant Dim dataRange As Range Dim result As Variant Set dataRange = dataSheet.Range("A:D") result = Application.WorksheetFunction.SumIfs(dataRange.Columns(4), dataRange.Columns(1), [E1], dataRange.Columns(2), customerCode) GetCustomerTotal = IIf(customerCode = "", "", result) End Function

السلام عليكم ورحمة الله وبركاته ربنا اغفر لي ولوالديّ وللمؤمنين يوم يقوم الحساب جزاكم الله خيراً

اسأل الله العلي القدير ان يرحم والدك ويرحم امواتنا جميعاً اللهم امين

بارك الله لك وتقبل منك شيت تحفه

وعليكم السلام ورحمة الله تعالى وبركاته بما ان البيانات من على النمودج ثابثة باستثناء( نوع الطلبية _ والوقت _ و رقم الطلبية) يمكنك محاولة ادراج ملخص الطلبية مباشرة بدون الاعتماد عليه جرب هدا الحل ربما يناسبك Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo Exitsub If Target.Row > 1 And Target.Column < 17 Then Dim lr As Long, r As Long Set WS = Sheet1 lr = WS.Range("i" & Rows.Count).End(xlUp).Row Application.ScreenUpdating = False With WS.Range("r2:r" & lr) .Formula = "=IF(I2<>"""",""في تمام الساعة( ""&CONCATENATE(TEXT(L2,""HH:mm"")&"" ) ""&""تم طلب "")&I2&"" ""&""منطقة (""&A2&"") "" &""وصول""&"" ""&"" ""&I2&"" ""&""الساعة""&"" ( ""&CONCATENATE(TEXT(N2,""HH:mm"")&"")""&"" ""&"" رقم الطلبية ( "")&F2&"") "","""")" .Value = .Value End With For r = 2 To WS.Cells(Rows.Count, "r").End(xlUp).Row If WS.Range("i" & r).Value = "" Then WS.Range("r" & r).Value = "" Next r End If Exitsub: End Sub نموذج V1.xlsm

Private Sub CommandButton4_Click() Dim WS As Worksheet: Set WS = Sheets("Home") Dim dest As Worksheet: Set dest = Sheets("Daily") Dim search As Range, Rng As Range Set search = WS.[F13]: Set Rng = WS.[F4:F13] If Application.WorksheetFunction.CountA(Rng) = 0 Or search = Empty Then MsgBox "المرجوا إدخال البيانات", vbExclamation, "Admin" Exit Sub Else If Application.WorksheetFunction.CountIf(dest.Range("j:j"), search) > 0 Then MsgBox " تم حفظ هذا اليوم مسبقا" & " " & search, vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه": Exit Sub a = Array([F4], [F5], [F6], [F7], [F8], [F9], [F10], [F11], [F12], [F13]) dest.[a65000].End(xlUp).Offset(1).Resize(, 10) = a dest.Range("j4:j" & Rows.Count).NumberFormat = "dd/mm/yyyy" Rng.ClearContents MsgBox "تم حفظ البيانات بنجاح" & " " & search & " " & "بنجاح", _ vbInformation, "Done" End If End Sub تقرير بورتوفيق.xlsm

وهذه مشاركتي البسيطة مع الأستاذ خليفة Sleep Mode.accdb

تفضل استاذ @Abdelaziz Osman مرفق من مكتبتي . Main_Form Close After 15 minute.rar

جرب Sub ProcessData() Dim ws1 As Worksheet, ws2 As Worksheet Dim lastRow As Long, i As Long Dim officeName As String, dateValue As String, claimNumber As String Dim uniqueOffices As New Collection Dim officeDates As New Dictionary Dim officeClaims As New Dictionary ' Set references to the worksheets Set ws1 = ThisWorkbook.Sheets("Sheet1") ' Change "Sheet1" to the actual name of your worksheet Set ws2 = ThisWorkbook.Sheets("Sheet2") ' Change "Sheet2" to the actual name of your worksheet ' Find the last row in worksheet 1 lastRow = ws1.Cells(ws1.Rows.Count, "O").End(xlUp).Row ' Loop through the data in worksheet 1 For i = 1 To lastRow ' Get the office name officeName = ws1.Cells(i, "O").Value ' Add the office name to the uniqueOffices collection On Error Resume Next uniqueOffices.Add officeName, CStr(officeName) On Error GoTo 0 ' Get the date value dateValue = CStr(ws1.Cells(i, "P").Value) ' Get the claim number claimNumber = CStr(ws1.Cells(i, "Q").Value) ' Add the date and claim number to the dictionaries if they don't already exist If Not officeDates.Exists(officeName) Then officeDates.Add officeName, dateValue officeClaims.Add officeName, claimNumber ElseIf InStr(1, officeDates(officeName), dateValue) = 0 Then officeDates(officeName) = officeDates(officeName) & " + " & dateValue ElseIf InStr(1, officeClaims(officeName), claimNumber) = 0 Then officeClaims(officeName) = officeClaims(officeName) & " + " & claimNumber End If Next i ' Write the unique office names to worksheet 2 Dim office As Variant Dim rowIndex As Long: rowIndex = 1 For Each office In uniqueOffices ws2.Cells(rowIndex, 1).Value = office ' Write the dates for each office ws2.Cells(rowIndex, 2).Value = officeDates(office) ' Write the claim numbers for each office ws2.Cells(rowIndex, 3).Value = officeClaims(office) rowIndex = rowIndex + 1 Next office MsgBox "Process complete." End Sub يرجى تغيير اسمي الورقتين "Sheet1" و "Sheet2" إلى الأسماء الفعلية للورقتين الخاصتين بك.

في حدث Private Sub Worksheet_Activate ضع الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) Dim a, i&, k&, b$, S$, lRow& Dim WS As Worksheet: Set WS = Sheets("البيانات") Dim desWS As Worksheet: Set desWS = Sheets("البحث") b = desWS.[E2] On Error Resume Next Application.ScreenUpdating = False If Not Intersect(Target, Target.Worksheet.Range("E2")) Is Nothing Then If Target.Cells.Value = "" Or IsEmpty(Target) Then Exit Sub desWS.Range("A5:j" & Rows.Count).ClearContents a = WS.Range("A3:J" & WS.[a65000].End(xlUp).Row) For i = 1 To UBound(a) If a(i, 4) = b Or a(i, 7) = b Or a(i, 10) = b Then desWS.Cells(k + 5, 1).Resize(, 10) = Application.IfError(Application.Index(a, i, Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)), "") k = k + 1 ActiveWindow.DisplayZeros = False End If Next lRow = desWS.Range("A:J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set Rng = desWS.Range("A5 :J" & lRow) desWS.Range("A5:J500").Borders.LineStyle = xlNone For Each c In Rng.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next Application.ScreenUpdating = True End If End Sub السيارات 24.xlsb

تفضل استاذ @فؤاد الدلوي المرفق بعد التعديل بطلبك . واذا كان هذا طلبك اضغط على أفضل إجابة . Test.rar

الف الف مبروك، وتحياتي لكل أعضاء المنتدى الغالي دمتم بالف خير 🌹🌹🌹

الف الف مبروك لك استاذ / @محمد احمد لطفى نتمني لك التوفيق ونفع الله بك وبعلمك

الف الف الف مبروك

تفضلي استاذة @safaa salem5 محاولتي . تغيير لون الخط وحجمه-1.rar

اللهم اغفر له وللمسلمين جميعا