Koşula Bağlı Kenarlık Çizimi

[demgüzar]

B17:B56 Hücrelerindeki değer 1'e eşit veya büyük ise

B17:H17 Hücrelerinde kenarlık olsun

Yani kod önce B17 hücresine bakacak eğer değer 1'e eşit veya büyük ise b17:h17 hücrelerine kenarlık çizecek

daha sonra b18 hücresine bakacak eğer değer 1'e eşit veya büyük ise
b18:h18 hücrelerine kenarlık çizecek

bu döngü b56 hücresine kadar devam edecek.

Bu kodu nasıl yazabilirim?

İlgilenen arkadaşlara teşekkürlerimle

 

[Seyit Tiken]

Koşullu Biçimlendirme ile de yapılabilir, kodla yaptık.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Intersect(Target, [b17:b56]) Is Nothing Then Exit Sub
If Target.Value >= 1 Then
For a = 1 To 7
Target(1, a).Borders(1).LineStyle = 1
Target(1, a).Borders(2).LineStyle = 1
Target(1, a).Borders(3).LineStyle = 1
Target(1, a).Borders(4).LineStyle = 1
Target(1, a).Borders(7).LineStyle = 1
Next
End If
End Sub

 

[demgüzar]

Hocam, ben çalıştıramadım ama sanırım kusur bendedir. Saygılarımla

 

[Korhan Ayhan]

Merhaba,

Önerilen kodu nasıl uyguladınız.

 

[demgüzar]

Merhaba,

Önerilen kodu nasıl uyguladınız.

Yazdığınız kodu kenarlık çizilmesini istediğim sayfanın kod bölümüne yapıştırdım.

 

[Korhan Ayhan]

Merhaba,

Doğru bölüme uygulamışsınız. Bu durumda kod sizin istediğiniz tepkiyi vermiyor.

Seyit beyin yazdığı kodda B17:B56 hücre aralığına tek tek 0 dan büyük değerler yazarsanız sonuç alırsınız. Alacağınız sonuçta satır bazlı olacaktır.

Eğer siz bu aralıktaki tüm hücreler için tek seferde bu kontrolün yapılmasını istiyorsanız aşağıdaki kodu kullanabilirsiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Hücre As Range
    If Intersect(Target, Range("B17:B56")) Is Nothing Then Exit Sub
    For Each Hücre In Range("B17:B56")
        If Hücre.Value >= 1 Then
            Hücre.Resize(1, 7).Borders.LineStyle = 1
        Else
            Hücre.Resize(1, 7).Borders.LineStyle = 0
        End If
    Next
End Sub