Makro ile kenarlık çizmek

[M.ACAR]

İyi geceler,

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
If Target.Cells.Count > 1 Then Exit Sub
On Error GoTo ws_exit:
Set rng = Application.Intersect(Target, Me.Range("D365000"))
If rng Is Nothing Then Exit Sub
With Target
Select Case UCase(.Value)

Case Is = "TAMAM": .Interior.ColorIndex = 3
Case Is = "ONAYLANDI": .Interior.ColorIndex = 19
Case Is = "DEVAM": .Interior.ColorIndex = 33
Case Is = "KONTROL": .Interior.ColorIndex = 35

Case Else
.Interior.ColorIndex = xlNone
End Select
End With

ws_exit:
End Sub
Kodu ile D365000 arasında veri girişi yaptığımda Koşullu biçimlendirme uygulanıyor,bu koda ilave olarak ,B sütununa veri girişi yapıldığında B3:AA65000 arasında kenarlık çizilmesini istiyorum,nasıl ilave yapmam lazım.

Çalıştığım dosya ektedir.

 

[Ömer]

Merhaba,

Bu şekilde deneyiniz..

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
If Target.Cells.Count > 1 Then Exit Sub
On Error GoTo ws_exit:
Set rng = Application.Intersect(Target, Me.Range("B3:B65000,D3:D65000"))
If rng Is Nothing Then Exit Sub
With Target
    If .Column = 2 Then
        If .Value = "" Then
            Range("B" & .Row & ":AA" & .Row).Borders.LineStyle = 0
        Else
            Range("B" & .Row & ":AA" & .Row).Borders.LineStyle = 1
        End If
    Else
        Select Case UCase(.Value)
        
        Case Is = "TAMAM": .Interior.ColorIndex = 3
        Case Is = "ONAYLANDI": .Interior.ColorIndex = 19
        Case Is = "DEVAM": .Interior.ColorIndex = 33
        Case Is = "KONTROL": .Interior.ColorIndex = 35
        
        Case Else
            .Interior.ColorIndex = xlNone
        End Select
    End If
End With
ws_exit:
End Sub

.

 

[M.ACAR]

Sayın : Ömer bey verdiğiniz kod için çok teşekkür ederim,Çalıştığım sayfa'da A sütununda=EĞER(B3="";"";1) E sütununda=EĞER(B3<>"";SATIRSAY(B$3:$B3);"") Bu formülleride makro ile satırlara ekleyebilirmiyiz,

 

[Ömer]

Bu şekilde deneyiniz..

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
If Target.Cells.Count > 1 Then Exit Sub
On Error GoTo ws_exit:
Set rng = Application.Intersect(Target, Me.Range("B3:B65000,D3:D65000"))
If rng Is Nothing Then Exit Sub
With Target
    If .Column = 2 Then
        If .Value = "" Then
            Range("B" & .Row & ":AA" & .Row).Borders.LineStyle = 0
            .Offset(0, -1).ClearContents
            .Offset(0, 3).ClearContents
        Else
            Range("B" & .Row & ":AA" & .Row).Borders.LineStyle = 1
            .Offset(-1, -1).Copy .Offset(0, -1)
            .Offset(-1, 3).Copy .Offset(0, 3)
        End If
    Else
        Select Case UCase(.Value)
        Case Is = "TAMAM": .Interior.ColorIndex = 3
        Case Is = "ONAYLANDI": .Interior.ColorIndex = 19
        Case Is = "DEVAM": .Interior.ColorIndex = 33
        Case Is = "KONTROL": .Interior.ColorIndex = 35
        Case Else
            .Interior.ColorIndex = xlNone
        End Select
    End If
End With
ws_exit:
End Sub

.

 

[M.ACAR]

Sayın : Ömer bey yardımınız için çok teşekkürler.