satır ve sütun renklendirme de sınırlama

[huseyinvurkan]

Merhabalar arama yapmadığım sanılmasın. Bu başlık altında onlarca kod buldum. Ancak hanigi satırın ne işe yaradığını bilmediğimden yardıma ihtiyacım var.
1- Aşağıdaki kod gayet güzel ama renklendirdiği satır ve sütunların sınırı yok. sayfa içinde nereye tıklasam çalışıyor. Onu tablo boyutunda nasıl sınırlandırabilirim. Mesela D3:AG50 aralığındaki bir tablo için. Renkler tablo dışına taşmamalı.


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Satır As Range, Sütun As Range

Set Satır = Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 256))
Set Sütun = Range(Cells(1, ActiveCell.Column), Cells(65536, ActiveCell.Column))

Cells.FormatConditions.Delete

With Satır
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:=1
.FormatConditions(1).Font.Bold = True
.FormatConditions(1).Interior.ColorIndex = 8
End With

With Sütun
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:=1
.FormatConditions(1).Font.Bold = True
.FormatConditions(1).Interior.ColorIndex = 8
End With

With ActiveCell
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:=1
.FormatConditions(1).Font.Bold = True
.FormatConditions(1).Interior.ColorIndex = 6
End With

2- Satır ve sütun renklendirmeleri aktif hücreye kadar olan aşağıdaki koda nasıl bir ekleme yapılırsa yukarıdaki gibi sayfadaki diğer renkleri silmez.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim oRow As String
Dim oCol As String
Dim DataRg As Range
Dim A As Range


Dim AllRg As Range

Set DataRg = Range("B2:Ah1000")
Set AllRg = Range("A1:Ah1000")

If Target.Cells.Count > 1 Then Exit Sub

If Not Application.Intersect(Target, DataRg) Is Nothing Then
AllRg.Interior.ColorIndex = xlNone
oRow = "A" & Target.Row & ":" & Target.Offset(0, -1).Address
oCol = Target.Offset(1 - Target.Row, 0).Address & ":" & Target.Offset(-1, 0).Address
Range(oRow).Interior.ColorIndex = 10
Range(oCol).Interior.ColorIndex = 17
Else
AllRg.Interior.ColorIndex = xlNone
End If

End Sub
Şimdiden teşekkürler

 

[PLİNT]

Merhaba
Aşağıdaki gibi deneyiniz;
1.Kod:

[SIZE="2"]Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Satır As Range, Sütun As Range
If Intersect(Target, [D3:AG50]) Is Nothing Then
[D3:AG50].FormatConditions.Delete
Exit Sub
End If
Set Satır = Range(Cells(ActiveCell.Row, 4), Cells(ActiveCell.Row, 33))
Set Sütun = Range(Cells(3, ActiveCell.Column), Cells(50, ActiveCell.Column))

Cells.FormatConditions.Delete

With Satır
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:=1
.FormatConditions(1).Font.Bold = True
.FormatConditions(1).Interior.ColorIndex = 8
End With

With Sütun
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:=1
.FormatConditions(1).Font.Bold = True
.FormatConditions(1).Interior.ColorIndex = 8
End With

With ActiveCell
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:=1
.FormatConditions(1).Font.Bold = True
.FormatConditions(1).Interior.ColorIndex = 6
End With
End Sub[/SIZE]

2. Kod:

[SIZE="2"]Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim oRow As String
Dim oCol As String
Dim DataRg As Range
Dim A As Range
Dim AllRg As Range
Set DataRg = Range("B2:Ah1000")
Set AllRg = Range("A1:Ah1000")

If Target.Cells.Count > 1 Then Exit Sub

If Not Application.Intersect(Target, DataRg) Is Nothing Then
AllRg.FormatConditions.Delete
oRow = "A" & Target.Row & ":" & Target.Offset(0, -1).Address
oCol = Target.Offset(1 - Target.Row, 0).Address & ":" & Target.Offset(-1, 0).Address
With Range(oRow)
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:=1
.FormatConditions(1).Font.Bold = True
.FormatConditions(1).Interior.ColorIndex = 10
End With
With Range(oCol)
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:=1
.FormatConditions(1).Font.Bold = True
.FormatConditions(1).Interior.ColorIndex = 17
End With
Else
AllRg.FormatConditions.Delete
End If

End Sub[/SIZE]

 

[huseyinvurkan]

Sayın plint elinize sağlık yardımınız için teşekkürler. Kodlar tam istediğim gibi olmuş.