ارجو من الاخوة الكرام اضافة كود عدم اهتزاز الشاشة الجزء الملون بالاحمر

[أبو قاسم]

Private Sub Worksheet_Change(ByVal Target As Range)

On Error Resume Next

Dim R As Integer

If Not Intersect(Target.Cells(1, 1), Union(Range("B2:B10000"), Range("o2:o10000"))) Is Nothing Then

    R = Target.Row

    If Cells(R, "B").Value <> "" Then

        Cells(R, "A").Value = R + 4999

        

       

        Cells(R, "C").Value = WorksheetFunction.VLookup(Cells(R, "B"), [TUNNEL3], 2, 0)

        

        Cells(R, "D").Value = WorksheetFunction.VLookup(Cells(R, "B"), [TUNNEL3], 3, 0)

    Else

        Union(Cells(R, "0"), Cells(R, "0")).ClearContents

    End If

          End If

               If Target.Cells.CountLarge > 1 Then Exit Sub

    If Target.Row > 1 And Target.Column = 8 Then

        With Target.Offset(, 1)

            .Formula = "=MOD(" & (Target - Target.Offset(, -1)) & ",1)": .Value = .Value

        End With

End If

     If Target.Cells.CountLarge > 1 Then Exit Sub

    If Target.Row > 1 And Target.Column = 11 Then

        With Target.Offset(, 1)

            .Formula = "=MOD(" & (Target - Target.Offset(, -4)) & ",1)": .Value = .Value

        End With

    End If

If Target.Cells.Count > 1 Then Exit Sub

 

        If Not Intersect(Target, Range("B:B")) Is Nothing Then

 

            With Target(1, 3)

 

                .Value = Date

 

               

            End With

           End If

On Error GoTo 0

End Sub

 

[أبو قاسم]

للرفع

[خالد الشاعر]

استاذ صلاح

 

يوضع هذا الامر فى بداية الكود

 

    Application.ScreenUpdating = False

 

و فى النهاية

 

    Application.ScreenUpdating = True

[أبو قاسم]

تشكر الف الف شكر ماقصرت