Hücre Değerini Otomatik Değiştirme

[katip16487]

Ekli dosyamda VERİ-DOĞRULAMA sistemi ile yaptığım hücrelerde EVET - HAYIR yazmaktadır....

Ancak, normal şartlar altında bütün hücrelerde EVET yazmaktadır...

Yapmak istediğim bu hücrelerden herhangi birisini HAYIR diye değiştirdiğimde o hücreden itibaren o sütundaki son hücreye kadar olan verilerin hepsinin HAYIR olarak değişmesi...

Ayrıca, başka bir hücre ile yapılan bağlantıda diğer hücrenin boş olması halinde BOŞ olmasını sağlamak istiyorum...

Bütün herkese saygılar sunarım...

Forumda yaptığım aramada benzer bişey bulamadım...

Var olanlar genelde formül kopyalama sistemi ile çalışan makrolar...

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu sayfanızın kod bölümüne uygulayıp deneyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("B2:B" & Rows.Count)) Is Nothing Then Exit Sub
    If Target.Cells.Count > 1 Then Exit Sub
    If Target = "HAYIR" Then
        Range("B" & Target.Row + 1 & ":B" & Rows.Count).ClearContents
        Range("B" & Target.Row & ":B" & Cells(Rows.Count, 1).End(3).Row) = "HAYIR"
    End If
End Sub

 

[ExcelF1]

Korhan Bey cevaplamışlar, bende yazmışken ekleyeyim, alternatif olsun.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, [B2:B65536]) Is Nothing Then Exit Sub
a = MsgBox("Kırmızı hap mı ? Yoksa mavi olan mı ?", vbYesNo, "Şaka Şaka ")
If a = vbYes Then
ActiveCell = "EVET"
Else
For b = ActiveCell.Row To [A65536].End(xlUp).Row
Cells(b, 2) = "HAYIR"
Next b
End If
c = [A65536].End(xlUp).Row + 1
Range(Cells(c, 2), Cells(65536, 2)).ClearContents
End Sub

 

[katip16487]

Her iki değerli arkadaşıma da teşekkür ediyorum...

Verdiğiniz kodları ayrı ayrı denememe rağmen nedense olmadı...

ÇALIŞMA SAYFAMDA BAŞKA BİR İŞLEM İÇİN VAR OLAN KOD:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Satır As Integer
If Intersect(Target, Range("J12:J130")) Is Nothing Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
If Target <> "" Then
Satır = Target.End(3).Row + 1
If Satır >= Target.Row Then Exit Sub
If Cells(Satır, Target.Column) = "" Then
Range(Cells(Satır, Target.Column), Cells(Target.Row - 1, Target.Column)) = CDate(Target)
Range("J12:J130").NumberFormat = "dd/mm/yyyy"
End If
End If
End Sub


kodu bulunmaktadır...

Yeni yazacağım kod ise L sütununda L12 ile L 131 hücreleri değerlerinde değişiklik yapmayı amaçlamaktadır...

Kodlarınızda buna ilişkin hücre güncellemesini de yapmama rağmen nedense çalıştıramadım...

Hata bende de olabilir...

Ama yine de teşekkürler...

 

[Korhan Ayhan]

Merbaha,

Bu tür detayları mesajlarınızda belirtmezseniz size cevap verenleri yanlış yönlendirmiş olursunuz.

Aşağıdaki şekilde deneyin.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Satır As Integer
    
    If Intersect(Target, Range("B2:B65536,J12:J130")) Is Nothing Then Exit Sub
    If Target.Cells.Count > 1 Then Exit Sub
        
    If Target <> "" Then
        If Target.Column = 2 Then
            If Target = "HAYIR" Then
                Range("B" & Target.Row + 1 & ":B" & Rows.Count).ClearContents
                Range("B" & Target.Row & ":B" & Cells(Rows.Count, 1).End(3).Row) = "HAYIR"
            End If
        
        Else
            Satır = Target.End(3).Row + 1
            If Satır >= Target.Row Then Exit Sub
            If Cells(Satır, Target.Column) = "" Then
                Range(Cells(Satır, Target.Column), Cells(Target.Row - 1, Target.Column)) = CDate(Target)
                Range("J12:J130").NumberFormat = "dd/mm/yyyy"
            End If
        End If
    End If
End Sub

 

[katip16487]

Korhan bey, ilginize teşekkür ederim...

Ancak, formül bu hali ile de çalışmadı ne yazık ki...



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

If Intersect(Target, Range("L12:L65536,J12:J131")) Is Nothing Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub

If Target <> "" Then
If Target.Column = 2 Then
If Target = "HAYIR" Then
Range("L" & Target.Row + 1 & ":L" & Rows.Count).ClearContents
Range("L" & Target.Row & ":L" & Cells(Rows.Count, 1).End(3).Row) = "HAYIR"
End If

Else
Satır = Target.End(3).Row + 1
If Satır >= Target.Row Then Exit Sub
If Cells(Satır, Target.Column) = "" Then
Range(Cells(Satır, Target.Column), Cells(Target.Row - 1, Target.Column)) = CDate(Target)
Range("J12:J131").NumberFormat = "dd/mm/yyyy"
End If
End If
End If
End Sub



Tekrar inceleme yapma imkanınız olursa HÜCRENİN BOŞ KALMASI kısmını çıkararak yapabilirsek muhtemelen çalışacaktır diye düşünüyorum...

Saygılarımla... Teşekkürlerimi sunarım...

Kod üzerinde yukarıda paylaştığım alanlar üzerinde çalışma yapmanız benim için kolaylık oluşacaktır...

Saygılarımla... Teşekkürlerimi sunarım...

 

[Korhan Ayhan]

Merhaba,

İlk eklediğiniz dosyaya uyarladım. Ben denedim ve çalışıyor.

İnceleyiniz.

Sarı renkli alanlarda işlem yapınız.