استبدل الماكرو بهذا
Private Sub Worksheet_Change(ByVal Target As Range)
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Dim My_Rg As Range
Dim x, y, k, c As Long
Set My_Rg = Range("a1").CurrentRegion
On Error GoTo Exit_Sub
x = My_Rg.Rows.Count
y = My_Rg.Columns.Count
My_Rg.Interior.ColorIndex = xlNo
Set My_Rg = My_Rg.Offset(1).Resize(x - 1).Offset(, y - 7).Resize(, y - 10)
If Not Intersect(Target, My_Rg) Is Nothing And Target.Cells.Count = 1 Then
For k = 1 To x
c = Application.CountA(My_Rg.Cells(k, 1).Resize(, y - 10))
If c > 0 Then Cells(k + 1, 2).Resize(1, 16).Interior.Color = 12900829
Next
End If
Exit_Sub:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub