Aktif Hücrenin(imleç) Bulunduğu Satırın Renklenmesi

[Seyit Tiken]

Herkese Selamlar,
İmleç hangi hücrede olursa olsun, o satırı ve altan iki satırı(toplam 3 satır)
renklendirmesi ve imleç aşağı ve yukarı doğru hareket ettikçe, renkli üç satırında hareket etmesini sağlayan bir makro kodu ile yapılabilir mi? Satır rengi MAVİ olabilir.
Teşekkürlerimi sunuyorum.

 

[Levent Menteşoğlu]

Aşağıdaki kodu Thisworkbook sayfasına kopyalayarak deneyin.

[vb:1:71aea50b3d]Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Cells.Interior.ColorIndex = xlNone
Rows(ActiveCell.Row & ":" & ActiveCell.Row + 2).Interior.ColorIndex = 33
End Sub
[/vb:1:71aea50b3d]

 

[Seyit Tiken]

Levent bey teşekkür ederim. Allah razı olsun. Þöyle bir şey de yapılabilir mi? Yukarıdaki soru ile ilgili. Renkli bant üç satırdan oluşuyor. İmleç bu üç satır içinde aşağı-yukarı, yukarı-aşağı hareket ettiği zaman renkli bant sabit kalsın, hareket etmesin. Ne zaman imleç renkli bandın dışına çıkarsa o bant hareket etsin. Tekrar Teşekkür eder saygılarımı sunuyorum.

 

[Levent Menteşoğlu]

Aşağıdaki kodu deneyin.

[vb:1:4851b06ea1]Dim ilksat, sonsat As Integer
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
On Error Resume Next
If ActiveCell.Row > ilksat And ActiveCell.Row < sonsat Then Exit Sub
Cells.Interior.ColorIndex = xlNone
Rows(ActiveCell.Row & ":" & ActiveCell.Row + 2).Interior.ColorIndex = 33
ilksat = ActiveCell.Row
sonsat = ActiveCell.Row + 3
End Sub[/vb:1:4851b06ea1]

 

[Seyit Tiken]

Çok çok teşekkürler size ve ekibinize. Muhteşem oldu. Kodu uyguladıkça yeni gereksinimler de beliriveriyor. Yaptığım basit programda bazı hücreler belirgin gözükmesi için farklı renkte dolgu renkleri kullanılmış. Yukarıdaki kod, İmlecin gittiği yerlerdeki, dolgu renklerini siliyor(beyaz yapıyor). Yani imleç hangi hücreye giderse eğer o satırlarda farklı renkte dolgu rengi varsa bozmasın(silmesin).
Kusura bakmayın.

 

[Levent Menteşoğlu]

Aşağıdaki kodu deneyin. Ekte birde örnek dosya sunuyorum.

[vb:1:77c9e6ca66]Dim ilksat, sonsat, deg As Integer
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
On Error Resume Next
If ActiveCell.Row > ilksat And ActiveCell.Row < sonsat Then Exit Sub
Cells.FormatConditions.Delete
[z1] = 1
Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row + 2, 20)).FormatConditions.Add Type:=xlExpression, Formula1:="=$z$1=1"
Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row + 2, 20)).FormatConditions(1).Interior.ColorIndex = 33
ilksat = ActiveCell.Row
sonsat = ActiveCell.Row + 3
End Sub
[/vb:1:77c9e6ca66]

 

[Seyit Tiken]

Hepinize saygı ve selamlarımı sunuyorum. Tek kelimeyle harikasınız. Süper oldu.

 

[kitreli]

Leventm Hocam; Ben verdi&#287;iniz makroyu uygulad&#305;m. Ancak burda 3 sat&#305;r oluyor.
Ben TEK sat&#305;r&#305;n sonuna kadar renklenmesini ve yaz&#305; stilinin kal&#305;nla&#351;mas&#305;n&#305; istiyorum.

 

[Kemal Demir]

Kodu ThisWorkbook K&#305;smn&#305;ya yaz&#305;n&#305;z.

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Cells.Interior.ColorIndex = xlNone
Cells.Font.Bold = False
Rows(ActiveCell.Row).Interior.ColorIndex = 33
[b]'Hedefteki Hucreyi Sarı renkle Gösterir[/b]
Target.Interior.ColorIndex = 6
End Sub

 

[Kemal Demir]

&#304;ki defa yollam&#305;s&#305;m.

 

[cenk77ist]

kod okunabilir değil, modifiye ettim.. ama güzel oldu

Dim ilksat, sonsat, deg As Integer
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

On Error Resume Next

Dim shp As Shape
For Each shp In ActiveSheet.Shapes
If shp.Name = "HoverPic" Then shp.Delete
Next shp

If Target.Count > 1 Then
Cells.FormatConditions.Delete
Exit Sub
End If

If ActiveCell.Row > ilksat And ActiveCell.Row < sonsat Then Exit Sub
Cells.FormatConditions.Delete
[z1] = 1
Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 20)).FormatConditions.Add Type:=xlExpression, Formula1:="=$z$1=1"
Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 20)).FormatConditions(1).Interior.ColorIndex = 3
Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 20)).FormatConditions(1).Font.ColorIndex = 6
Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 20)).FormatConditions(1).Font.Bold = True

ActiveCell.FormatConditions(1).Interior.ColorIndex = 33
ActiveCell.FormatConditions(1).Font.ColorIndex = 1

Dim t As Double, h As Double, l As Double, w As Double
Dim Scalar As Double, LineThick As Double, FillColor As Double
Dim LineVis As Boolean, ShadowVis As Boolean
Dim SelRange As Range, Area As Range

Scalar = 1.5 'adjust the scalar to make the shapes bigger/smaller (can also be less than 1)
LineThick = 2 * Scalar
LineVis = True
FillColor = 6 + 7 'yellow
ShadowVis = True

Set SelRange = ActiveCell 'Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 20)) 'ActiveWindow.RangeSelection
For Each Area In SelRange.Areas
With Area
.Select
.Copy
t = .Top
h = .Height
l = .Left
w = .Width
End With
With ActiveSheet.Pictures.Paste(Link:=True)
.Name = "HoverPic"
.ShapeRange.Fill.Solid
.Top = t + h + 1
.Left = l + w + 1
.Formula = ""
.Top = t
.Left = l
.ShapeRange.ScaleWidth Scalar, msoFalse, msoScaleFromMiddle
.ShapeRange.ScaleHeight Scalar, msoFalse, msoScaleFromMiddle
.ShapeRange.Line.Visible = LineVis
.ShapeRange.Line.Weight = LineThick
.ShapeRange.Fill.ForeColor.SchemeColor = FillColor
.ShapeRange.Shadow.Type = msoShadow6
.ShapeRange.Shadow.Visible = ShadowVis
End With
Next Area
SelRange.Select

ilksat = ActiveCell.Row
sonsat = ActiveCell.Row


End Sub

 

[kitreli]

Cenk77ist; makro g&#252;zel olmu&#351; eline sa&#287;l&#305;k.. Ancak ben h&#252;crenin o kadar b&#252;y&#252;mesini istemiyorum.. Sadece o sat&#305;r&#305;n(sat&#305;r olarak) yaz&#305; tipinin kal&#305;n olmas&#305;n&#305;(si&#231;ili oldu&#287;u zaman) istiyorum.
Se&#231;ildi&#287;i zaman Dolgu renginin siyah yaz&#305; renginin de beyaz olmas&#305;n&#305; istiyorum...