كود لعمل خط تحت الدرجة الاقل

[بلانك]

كود لعمل خط تحت الدرجة الاقل كما بالمرفق وشكرا مقدما

كود لعمل خط تحت الدرجة الاقل.xlsx

[عبدالله بشير عبدالله]

جرب الملف 

كود لعمل خط تحت الدرجة الاقل.xlsb

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته 

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim lastRow As Long, OnRng As Variant, i As Long
    Dim WS As Worksheet: Set WS = Me
    Dim Max As Integer
    Max = 20

    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    If Not Intersect(Target, WS.Range("C3:C" & WS.Rows.Count)) Is Nothing Then
        lastRow = WS.Cells(WS.Rows.Count, "C").End(xlUp).Row
        OnRng = WS.Range("C3:C" & lastRow).Value

        For i = 1 To UBound(OnRng, 1)
            With WS.Cells(i + 2, "C")
                If IsNumeric(OnRng(i, 1)) And OnRng(i, 1) < Max Then
                    .Font.Underline = xlUnderlineStyleSingle
                    .Font.Color = RGB(255, 0, 0)
                Else
                    .Font.Underline = xlUnderlineStyleNone
                    .Font.Color = RGB(0, 0, 0)
                End If
            End With
        Next i
    End If

    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

 

كود لعمل خط تحت الدرجة الاقل.xlsb

[بلانك]

بارك الله فيكم جميعا فعلا منتدى الخير والمساعدة للاخرين في عالم الاكسل

[بلانك]

لو يمكن كود اخر بسيط لحذف الخط من تحت الرقم

[محمد هشام.]

Sub Supprimer_lignes()
    Dim lastRow As Long
    Dim WS As Worksheet :Set WS = Sheets("Sheet1")
    lastRow = WS.Cells(WS.Rows.Count, "C").End(xlUp).Row
    For i = 4 To lastRow
        WS.Cells(i, "C").Font.Underline = xlUnderlineStyleNone
    Next i
End Sub

إذا كنت ترغب في حذف الأشكال

Sub Supprimer_Shapes()
    Dim WS As Worksheet, shp As Shape, lastRow As Long
    Set WS = Sheets("Sheet1")
    
    lastRow = WS.Cells(WS.Rows.Count, "C").End(xlUp).Row
    
    For Each shp In WS.Shapes
        If Not Intersect(shp.TopLeftCell, WS.Range("C4:C" & lastRow)) Is Nothing Then: shp.Delete
    Next shp
End Sub

 

تم تعديل فبراير 10, 2025 بواسطه محمد هشام.

[بلانك]

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

كود لعمل خط تحت الدرجة الاقل.xlsb

تم تعديل فبراير 10, 2025 بواسطه بلانك

[محمد هشام.]

كود لعمل خط تحت الدرجة الاقل..xlsb

[بلانك]

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

[محمد هشام.]

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

23 ساعات مضت, بلانك said:

لو يمكن كود اخر بسيط لحذف الخط من تحت الرقم

هدا ما فهمت من طلبك الأخير 

 

3 ساعات مضت, بلانك said:

الكود الاول لايضع خط تحت الارقام الاقل من 20 والكود الثاني لايحذف هذة الخطوط

رغم أن الكود الأول تم تزويدك به مسبقا جرب هدا 

Option Explicit
Public Property Get WS() As Worksheet: Set WS = Sheets("Sheet1"): End Property
 Sub add_Underline()
    Dim lastRow As Long, OnRng As Variant, i As Long
    Dim Max As Integer
    Max = 20

    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    lastRow = WS.Cells(WS.Rows.Count, "C").End(xlUp).Row
    OnRng = WS.Range("C3:C" & lastRow).Value

    For i = 1 To UBound(OnRng, 1)
        With WS.Cells(i + 2, "C")
            If IsNumeric(OnRng(i, 1)) And OnRng(i, 1) < Max Then
                .Font.Underline = xlUnderlineStyleSingle
                .Font.Color = RGB(255, 0, 0)
            Else
                .Font.Underline = xlUnderlineStyleNone
                .Font.Color = RGB(0, 0, 0)
            End If
        End With
    Next i

    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub
'=============================
Sub Supprimer_lignes()
    Dim lastRow As Long, i As Long
    lastRow = WS.Cells(WS.Rows.Count, "C").End(xlUp).Row
    For i = 4 To lastRow
        WS.Cells(i, "C").Font.Underline = xlUnderlineStyleNone
        WS.Cells(i, "C").Font.Color = RGB(0, 0, 0)
    Next i
End Sub

كود لعمل خط تحت الدرجة الاقل V2.xlsb

تم تعديل فبراير 10, 2025 بواسطه محمد هشام.

[بلانك]

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