Thisworkbook kod desteği

[serkanım]

Selamlar,

excel dosyasındaki thisworkbook sayfasındaki yazan kodlara ilave sorgulama eklemek istiyorum.dosyaya açılama yazdım.Yardımcı olabilirseniz sevinirim.

Teşekkürler,

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu denermisiniz.

Ayrıca kullandığınız kod sayfaya ait bir koddur. Fakat başlığınızda kitaba ait bir kod bölümünü belirtmişsiniz. Düzeltmenizde fayda var.

Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Alan1 As Range, Alan2 As Range, Bul As Range, Adres As String
    
    On Error GoTo Son
    
    If Intersect(Target, [E2:E65536,K2:K65536]) Is Nothing Then Exit Sub
    If Target.Column = 5 Then
        Set Alan1 = Range("A" & Target.Row & ":E" & Target.Row)
        
        If Target = "" Then
            Alan1.Interior.ColorIndex = xlNone
        Else
            Application.EnableEvents = False
            Alan1.Interior.ColorIndex = 15
            Range("B" & Target.Row).ClearContents
            Set Bul = Range("A:A").Find(Cells(Target.Row, "A"), , , xlWhole)
            If Not Bul Is Nothing Then
                Adres = Bul.Address
                Do
                    Range("E" & Bul.Row) = Target
                    Range("A" & Bul.Row & ":E" & Bul.Row).Interior.ColorIndex = 15
                    Range("B" & Bul.Row).ClearContents
                Set Bul = Range("A:A").FindNext(Bul)
                Loop While Not Bul Is Nothing And Bul.Address <> Adres
            End If
        End If
    End If
Son:
    Application.EnableEvents = True
End Sub

 

[serkanım]

Merhabalar

Yardımlarınız için çok teşekkür ederim.

emeğinize sağlık

 

[serkanım]

Merhaba

Korhan bey yazmış olduğunuz kodlara bir sorgulama daha eklemenizi rica edebilirmiyim.
A sutununda herhangibir değer yok ise işlem yapmadan çıksın.
Şuanda E sutununa bir değer girdiğimde A sutunundaki hücre boş ise tüm sutunları reklendiriyor.
şimdiden teşekkür ederim..