Birbirini değiştiren hücre

[ikikan]

Arkadaşlar şöyle bir kod olabilirmi ! A1 hücresi değişince B1 hücresini değiştirecek, B1 hücresi değişince A1 hücresi değişecek?

Örnek vermek gerekirse A1=0 olsun B1= 1000
A1= 100 yapınca B1= 900 olacak
B1=950 yazınca A1= 50 olacak
ayrıca yardımcı bir hücre kullanılmayacak


Sizce mümkün mü?

 

[Ömer]

Merhaba,

Çalışma sayfasının kod bölümüne kopyalayın.

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim deg As Double, s As Byte

    If Intersect(Target, [A1:B1]) Is Nothing Then Exit Sub
    
    deg = 1000
    
    With Target
        If .Count > 1 Then Exit Sub
        s = 1
        If .Column = 2 Then s = 0
        Range("A1").Offset(, s) = deg - .Value
    End With

End Sub

 

[YUSUF44]

Aşağıdaki kodu ilgili sayfanın kod bölümüne (sayfa adına sağ tıklayıp kod görüntüle deyince açılan sayfaya) yapıştırıp deneyiniz:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A1:B1]) Is Nothing Then Exit Sub
Application.EnableEvents = False
    If Target.Column = 1 Then
        Target.Offset(0, 1) = 1000 - Target
    Else
        Target.Offset(0, -1) = 1000 - Target
    End If
Application.EnableEvents = True
End Sub

 

[veyselemre]

Sayfanın kod sayfasına yapıştırın.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, [A1:B1]) Is Nothing And IsNumeric(Target) And Target.Count = 1 Then
        Application.EnableEvents = False
        If Target.Address = "$A$1" Then
            [b1] = 1000 - Target
        Else
            [a1] = 1000 - Target
        End If
        Application.EnableEvents = True
    End If
End Sub

 

[Seyit Tiken]

Ben olayı böyle anladım.

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [a1]) Is Nothing Then
If Target = 100 Then Target.Offset(, 1) = 900
End If
If Not Intersect(Target, [b1]) Is Nothing Then
If Target = 950 Then [a1] = 50
End If
End Sub