D6 hücresine 12000 yazsın

[k0081]

Merhaba arkadaşlar;

D4 hücresine ; D6, D8, D10, D12, D14, D16, D18, D20, D22, D24, D26, D28, D30, D32, D34 değerlerinden herhangi birisi yazıldığında D6 hücresine 12000 yazsın.. D6..D34 değerlerinin haricinde bir değer girildiğinde, D6 hücresinde herhangi bir değişiklik yapmasın...

yardımcı arkadaşa şimdiden Teşekkürler..

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

Private Sub Worksheet_Change(ByVal Target As Range)
 
    Dim i As Byte
    
    If Intersect(Target, Range("D4")) Is Nothing Then Exit Sub
    If Target = "" Then Exit Sub
    
    For i = 6 To 34 Step 2
        If Target = Cells(i, "D") Then
            Range("D6") = "12000"
            Exit Sub
        End If
    Next i
        
End Sub

.

 

[k0081]

Merhaba ömer hocam;

If Target = Cells(i, "D") Then bu kısmda hata alıyorum hocam.. worksheet change olayımda başka kodlar da var.. sanırım çakışma var gibi..

 

[Ömer]

Diğer kodlar nedir?

 

[k0081]

Bu kodlar hocam.. bir de boş bir sayfada denedim,, yine çalıştıramadım son göndermiş olduğunuz kodu..

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Say As String, yaz As String
 
 
 
    If Intersect(Target, Range("D3:D5,E2")) Is Nothing Then Exit Sub
 
    If Target.Column = 4 Then
        With Application
            If Target <> "" Then
                .EnableEvents = False
                Target = UCase(Replace(Replace(Target, "ı", "I"), "i", "İ"))
                If Target.Address = "$D$4" Then Target = _
                                Replace(Target, "*", "x")
                Range("D5").NumberFormat = "@"            ' çarma işleminin yapılmasını sağlıyor
                Range("D5") = Evaluate("=" & Range("D5")) 'bölme işleminin yapılmasını sağlıyor
               

                .EnableEvents = True
            End If
        End With
    End If
 
    If Target.Column = 5 Then
        Say = WorksheetFunction.Rept("0", [E2])
        If [E2] > 0 Then yaz = "." & Say Else: yaz = ""
        Range("H5:H53").NumberFormat = "#,##0" & yaz & """ m"""

    End If


 
    End Sub

 

[Ömer]

İlk mesajdaki soruda konuyu hatalı yada yanlış yazımla anlatmış olabilirmisiniz.

Kontrol edermisiniz.

Sonrasında iki kodu birleştiririz.

 

[k0081]

İlk mesajdaki soruda konuyu hatalı yada yanlış yazımla anlatmış olabilirmisiniz.

Kontrol edermisiniz.

Sonrasında iki kodu birleştiririz.

Hayır. Eksik yada yanlış anlatım söz konusu değil..

 

[Ömer]

İlk sorunuzdaki örnek ekte. Kırmızı (D4) hücresine değer girince hangi durumda istenen değeri alamadınız.

.