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

[أيمن ابراهيم]

المطلوب المساعدة من السادة خبراء المنتدى الكرام المساعدة بكود  

تسطير حدود النطاق من ( B5: G20  )كما هو موضح بالملف المرفق

  في حالة ان الخلية الموجودة في العمود B لا تساوي فراغ

وفي حالة مسح البيانات من الخلية الموجودة في العمود  Bيتم مسح الحدود من كامل السطر

تم عمل ذلك في الورقة 2 فى النطاق ( C5 : H20 )ولكن باستخدام التنسيق الشرطي ، ولكن بنوع واحد من الخطوط

المصنف1.rar

[ياسر خليل أبو البراء]

أخي العزيز أيمن إبراهيم

ضع الكود التالي في موديول

Sub Borders()
    Dim Rng As Range, Cel As Range
    Set Rng = Range("B5:B20")
    
    Application.ScreenUpdating = False
        Rng.Borders.LineStyle = xlNone
        For Each Cel In Rng
            If Cel.Value <> "" Then
                With Cel.Resize(1, 6)
                    .Borders.Weight = xlThin: .BorderAround Weight:=xlMedium
                End With
            Else
                Cel.Resize(1, 6).Borders.LineStyle = xlNone
            End If
        Next Cel
    Application.ScreenUpdating = True
End Sub

وقم بوضع الكود التالي في حدث الورقة الأولى

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column = 2 And Target.Row > 4 Then
        Call Borders
    End If
End Sub

تقبل تحياتي

 

[سليم حاصبيا]

استعمل هذا الكود

Private Sub Worksheet_Change(ByVal Target As Range)
 If Target.Column = 2 And Target.Row >= 5 And Target.Row <= 20 And Target.Count = 1 Then dd
 End Sub
Sub dd()
Dim My_range As Range
Dim my_2range As Range

Set My_range = Range("b5:g20")
 My_range.Borders.LineStyle = xlNone
  For i = 1 To My_range.Rows.Count
 If My_range.Cells(i, 1) <> "" Then
 Set my_2range = My_range.Range(Cells(i, 1), Cells(i, 6))
  With my_2range.Borders
        .LineStyle = xlContinuous
        .Weight = xlThick
    End With
    End If
    Next
End Sub

 

[ياسر خليل أبو البراء]

أخي الحبيب سليم

بارك الله فيك ..

لاحظ الكود الخاص بك في حالة قمت بمسح مجموعة من الخلايا .. لن يتم مسح التسطير السابق لأنك حددت شرط Target.Count=1 ..يمكنك إزالة الشرط ليتحصل المطلوب بشكل أفضل

[أيمن ابراهيم]

5 ساعات مضت, ياسر خليل أبو البراء said:

أخي العزيز أيمن إبراهيم

ضع الكود التالي في موديول

Sub Borders()
    Dim Rng As Range, Cel As Range
    Set Rng = Range("B5:B20")
    
    Application.ScreenUpdating = False
        Rng.Borders.LineStyle = xlNone
        For Each Cel In Rng
            If Cel.Value <> "" Then
                With Cel.Resize(1, 6)
                    .Borders.Weight = xlThin: .BorderAround Weight:=xlMedium
                End With
            Else
                Cel.Resize(1, 6).Borders.LineStyle = xlNone
            End If
        Next Cel
    Application.ScreenUpdating = True
End Sub

وقم بوضع الكود التالي في حدث الورقة الأولى

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column = 2 And Target.Row > 4 Then
        Call Borders
    End If
End Sub

تقبل تحياتي

 

اشكرك استاذى الفاضل ياسر خليل على اهتمامك

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

جعلك الله عوناً لنا تقبل تحياتي

5 ساعات مضت, سليم حاصبيا said:

استعمل هذا الكود

Private Sub Worksheet_Change(ByVal Target As Range)
 If Target.Column = 2 And Target.Row >= 5 And Target.Row <= 20 And Target.Count = 1 Then dd
 End Sub
Sub dd()
Dim My_range As Range
Dim my_2range As Range

Set My_range = Range("b5:g20")
 My_range.Borders.LineStyle = xlNone
  For i = 1 To My_range.Rows.Count
 If My_range.Cells(i, 1) <> "" Then
 Set my_2range = My_range.Range(Cells(i, 1), Cells(i, 6))
  With my_2range.Borders
        .LineStyle = xlContinuous
        .Weight = xlThick
    End With
    End If
    Next
End Sub

 

اشكرك استاذنا الفاضل سليم على اهتمامك البالغ

ولكن كما قال الاستاذ ياسر خليل عند مسح المحتويات يظل التسطير كما هو

تقبل تحياتي

[ياسر خليل أبو البراء]

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

حاول تعملها بنفسك الموضوع مش صعب محتاج بس شوية تركيز

[أيمن ابراهيم]

اشكرك استاذى الفاضل ياسر خليل

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