Aynı anda birden çok hücrede 'Worksheet_Change' olayı

[tamer42]

Merhaba,
Aşağıdaki Worksheet_Change kodda "D" sütununda tek bir hücreye değer yazınca çalışmakta;

"D" sütununa 1' den fazla hücreye toplu olarak kopyala yapıştır yapınca çalışmmıyor,

Bunun bir çözümü var mıdır?
teşekkürler,
iyi Çalışmalar.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Integer

If Target.Column <> 4 Then Exit Sub
If Not IsNumeric(Target.Value) Then Exit Sub

On Error GoTo 120

r = Target.Row

Target.Offset(, -1).Value = Target.Value - 10

120:

End Sub

 

[Korhan Ayhan]

Sayfanın Change olayında toplu işlemler için döngü kullanabilirsiniz.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim My_Area As Range, Rng As Range

    Set My_Area = Intersect(Target, Range("D:D"))

    If Not My_Area Is Nothing Then
        For Each Rng In My_Area
            If IsNumeric(Rng) Then
                Rng.Previous = Rng - 10
            End If
        Next
    End If
End Sub

 

[Erkan Akayay]

Birde toplu olarak kopyala yapıştır için Application.EnableEvents ayarlamanız gerekir.

Private Sub Worksheet_Change(ByVal Target As Range)

Dim r As Integer

If Target.Column <> 4 Then Exit Sub

If Not IsNumeric(Target.Value) Then Exit Sub

Application.EnableEvents = False

On Error GoTo 120


r = Target.Row

Target.Offset(, -1).Value = Target.Value - 10

120:

Application.EnableEvents = True

End Sub

 

[kulomer46]

Merhaba

Alternatif olarak aşağıdaki kodlarda iş görebilir.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Integer
Dim hcr As Range

If Target.Column <> 4 Then Exit Sub
'''If Not IsNumeric(Target.Value) Then Exit Sub

On Error GoTo 120

For Each hcr In Selection
hcr.Offset(, -1).Value = hcr.Value - 10
Next

120:
End Sub

Fakat yukarda #2 numaralı mesajda daha kapsamlı bir çözüm paylaşılmıştır.
#2 numaralı mesajdaki çözümü kullanalım.

Selamlar...

 

[veyselemre]

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r As Range
    If Target.Count > 1 Then Application.EnableEvents = False
    For Each r In Target
        If r.Column = 4 Then
            If r.Value = "" Then
                r.Offset(, -1).ClearContents
            ElseIf IsNumeric(r.Value) Then
                r.Offset(, -1).Value = r.Value - 10
            End If
        End If
    Next r
    Application.EnableEvents = True
End Sub

 

[tamer42]

Sayfanın Change olayında toplu işlemler için döngü kullanabilirsiniz.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim My_Area As Range, Rng As Range

    Set My_Area = Intersect(Target, Range("D:D"))

    If Not My_Area Is Nothing Then
        For Each Rng In My_Area
            If IsNumeric(Rng) Then
                Rng.Previous = Rng - 10
            End If
        Next
    End If
End Sub

teşekkürler Korhan Hocam,
iyi ki varsınız!