تم رفع هذا الكود فى مشاركة منفصله
حتى لا ننسى هذه المشاركة كود لتعديل الإطار
تم ارفاق كود الحل من الفاضل _ أ / أبوعبد الله
لاحظ بالملف المرفق بمجرد ادخال بيانات فى العمود _G _ التاريخ يتم تحرك سطر التحديد
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
On Error Resume Next
If Intersect(Target, Range("G3:G1000")) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("G3:G1000")) Is Nothing And Target.Value <> "" And Target.Offset(1, 0).Value = "" Then
Range(Target, Target.Offset(0, -6)).Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Color = -8355712
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Color = -8355712
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Color = -8355712
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Color = -8355712
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Color = -8355712
.TintAndShade = 0
.Weight = xlHairline
End With
Target.Offset(1, -6).Select
Else
Range(Target, Target.Offset(0, -6)).Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Color = -8355712
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Color = -8355712
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Color = -8355712
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Color = -8355712
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Color = -8355712
.TintAndShade = 0
.Weight = xlHairline
End With
Target.Select
End If
Application.ScreenUpdating = True
End Sub
و لا تنسونا من صالح الدعاء
Format Cells - Border-1.rar