• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Aktif hücrenin bulunduğu satırı renklendirme

ASLAN7410

ASLAN7410

Katılım
15 Temmuz 2012
Mesajlar
2,802
Excel Vers. ve Dili
Ofis 2021 TR 64 Bit
Aktif hücrenin bulunduğu satırı renklendirme ve kenarlık

Merhaba arkadaşlar hayırlı geceler.

Aşağıdaki kod aktif hücrenin bulunduğu satırı renklendiriyor. Benim istediğim aktif hücre renlendiğinde yazınında kırmızı olmasını istiyorum, ekleme yapmaya çalıştım ancak kod işinden anlamadığım için yapamadım. Yardımcı olacak arkadaşlara şimdiden teşekkürler.


Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Cells.Interior.ColorIndex = xlNone
    If Intersect(Target, [A1:L500]) Is Nothing Then Exit Sub
    Range(Cells(Target.Row, 1), Cells(Target.Row, 12)).Interior.ColorIndex = 4
End Sub
 
Son düzenleme:
Buyurun.:cool:
Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Cells.Interior.ColorIndex = xlNone
    If Intersect(Target, [A1:L500]) Is Nothing Then Exit Sub
    Range(Cells(Target.Row, 1), Cells(Target.Row, 12)).Interior.ColorIndex = 4
    [B][COLOR="Red"]Range(Cells(Target.Row, 1), Cells(Target.Row, 12)).Font.Color = vbBlue[/COLOR][/B]
End Sub
 
Merhaba.
Mevcut kod'u aşağıdakiyle değiştirin.
Kod: 
[FONT="Trebuchet MS"]Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Cells.Interior.ColorIndex = [B]xlNone[/B]
    Cells.Font.Color = [B]vbBlack[/B]
[B][COLOR="Red"]If[/COLOR][/B] Intersect(Target, [A1:L500]) Is Nothing Then Exit Sub
    Range(Cells(Target.Row, 1), Cells(Target.Row, 12)).Interior.Color = [B]vbGreen[/B]
    Range(Cells(Target.Row, 1), Cells(Target.Row, 12)).Font.Color = [B]vbRed[/B]
End Sub[/FONT]
 
Evren Bey ve Ömer Bey ilginize çok teşekkür ediyorum, her iki kodda güzel çalışıyor ellerinize sağlık hayırlı geceler.
 
Merhaba arkadaşlar konuyu ben açtığım için aynı konu olduğundan tekrar yeni bir konu açmadım.

Forumda bulmuş olduğum ekte gönderdiğim örnek sayfa içerisindeki aktif hücrenin bulunduğu satır renkleniyor, bu benim çok işime yarıyor.

Benim yapmak istediğim sayfa içerisine koşullu biçimlendirme olarak kenarlık ekliyorum, hücreye tıkladığımda kenarlıklar gidiyor, bu kod içerisine A sütunundaki dolu olan bilgileri kontrol eden bir kenarlık eklemek istiyorum, yada sayfanın koşullu biçimlendirme ile oluşturulan kenarlık koşulu gitmesin.

Günlerdir uğraşıyorum, foruma ayrı ayrı değişik şekilde sorular sordum, aldığım bilgilere göre sayfaya uyarlamaya çalıştım benim istediğim gibi olmadı.

Yardım edecek arkadaşlara şimdiden çok teşekkür ederim.

Kod: 
http://s6.dosya.tc/server3/6i37ku/Ornek1.xls.html
 

Ekli dosyalar

Son düzenleme:
Sayın yönetici arkadaşlar konu hala günceldir.
 
Sayın Levent Bey ilginize teşekkür ederim, eklentiyi sayfaya ekledim ancak çalışmadı, başka belirtmiş olduğunuz linklerin bazıları çalışmıyor.

Sayın Ömer Bey ilginize teşekkür ederim, göndermiş olduğunuz örnek benim istediğim gibi bir örnek değil.

Yeniden küçük bir örnek hazırlayarak ekte gönderiyorum, sayfa içerisinde gerekli açıklama yaptım umarım anlaşılır.
 

Ekli dosyalar

Merhaba Sayın ERASLAN.

İstediğiniz şeyi sadece,
.. 1-100 satır aralığında ve
.. A:L sütun aralığında
geçerli olmak üzere;

Seçili satır
......sarı zeminli
......A sütunu dolu ise kenarlık var,

Seçili olmayan satırlar
......Zemin rengi yok
......A sütunu dolu ise kenarlık var,

şeklinde anlıyorum doğru mudur acaba?
 
Evet Ömer Bey aynen sizin dediğiniz gibi, yani benim derdim Sayfa3'teki hücre kenarlıklar siliniyor, bunun için bu kod arasına kenarlık koşulu eklemek.
 
Son düzenleme:
Tekrar merhaba.
Sayfa3'ün kod bölümündeki mevcut kodları silip yerine aşağıdaki uygulayınız.
Uygulama şu şekilde;
-- J1 hücresi boşsa,
-- Seçili satır A sütunundaki son dolu hücrenin satırından sonraysa
-- Seçili sütun H sütunundan sonraysa
biçimlendirme sadece kenarlık var,
-- J1 1 iken seçili satır A sütunundaki son dolu satırdan önce veya H sütunundan gerideyse A:H arası koyu, kırmızı karakter, sarı zemin.
Sanırım istediğiniz bu şekilde.
Kod: 
[B]Private Sub Worksheet_Activate()[/B]
Dim s1 As Worksheet: Set s1 = Sheets("Sayfa1")
Dim s2 As Worksheet: Set s2 = Sheets("Sayfa3")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
sonsat = s1.Cells(65536, 1).End(3).Row
sonsut = s1.Cells(1, 1).End(2).Column
s2.Cells.ClearContents
For a = 1 To sonsat
    For b = 1 To sonsut
        s2.Cells(a, b) = s1.Cells(a, b)
    Next
Next
s2.[J1] = 1
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
[B]End Sub[/B]

[B]Private Sub Worksheet_SelectionChange(ByVal Target As Range)[/B]
On Error Resume Next

If Application.CutCopyMode = xlCopy Then Exit Sub
If Application.CutCopyMode = xlCut Then Exit Sub

If Range("J1") <> 1 Or Target.Column > 8 Or Target.Row > [A65536].End(3).Row Then
    With Range("A1:H" & [A65536].End(3).Row)
        .Borders.LineStyle = xlContinuous
        .Interior.Color = xlNone
        .Font.ColorIndex = 1
        .Font.Bold = False
    End With
Exit Sub
End If
    Cells.Interior.Color = xlNone
    Cells.Font.Bold = False
    Cells.Font.ColorIndex = 1
    Range("A" & Target.Row & ":H" & Target.Row).Interior.ColorIndex = 6
    Range("A" & Target.Row & ":H" & Target.Row).Font.Bold = True
    Range("A" & Target.Row & ":H" & Target.Row).Font.ColorIndex = 3
Call BİÇİM
[B]End Sub[/B]

[B]Sub BİÇİM()[/B]
If Range("J1") <> 1 Then Exit Sub
b = [A65536].End(3).Row
alan1 = "A1:H" & ActiveCell.Row - 1
alan2 = "A" & ActiveCell.Row + 1 & ":H" & b
a = "=$A" & ActiveCell.Row + 1

Cells.FormatConditions.Delete

    Range(alan1).FormatConditions.Add Type:=xlExpression, Formula1:="=$A1<>"""""
    Range(alan1).FormatConditions(Range(alan1).FormatConditions.Count).SetFirstPriority
    With Range(alan1).FormatConditions(1)
        .Interior.PatternColorIndex = xlAutomatic
        .Borders.LineStyle = xlContinuous
        .Borders.Weight = xlThin
    End With
    Range(alan1).FormatConditions(1).StopIfTrue = False
    Range(alan2).FormatConditions.Add Type:=xlExpression, Formula1:=a & "<> """""
    Range(alan2).FormatConditions(Range(alan2).FormatConditions.Count).SetFirstPriority
    With Range(alan2).FormatConditions(1)
        .Interior.PatternColorIndex = xlAutomatic
        .Borders.LineStyle = xlContinuous
        .Borders.Weight = xlThin
    End With
    Range(alan2).FormatConditions(1).StopIfTrue = False
[B]End Sub[/B]
 
Kod: 
Private Sub Worksheet_Activate()
Dim s1 As Worksheet: Set s1 = Sheets("Sayfa1")
Dim s2 As Worksheet: Set s2 = Sheets("Sayfa3")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
sonsat = s1.Cells(65536, 1).End(3).Row
sonsut = s1.Cells(1, 1).End(2).Column
s2.Cells.ClearContents
For a = 1 To sonsat
    For b = 1 To sonsut
        s2.Cells(a, b) = s1.Cells(a, b)
    Next
Next
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
If Application.CutCopyMode = xlCopy Then Exit Sub
If Application.CutCopyMode = xlCut Then Exit Sub
Call RenkSil
[j1] = 1
With Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 8))
.FormatConditions.Add Type:=xlExpression, Formula1:="=$j$1=1"
.FormatConditions(1).Interior.ColorIndex = 6
.FormatConditions(1).Font.Bold = True
.FormatConditions(1).Font.ColorIndex = 3
End With

Call kenarlık
End Sub
Sub RenkSil()
On Error Resume Next
Cells.FormatConditions.Delete
End Sub
Sub kenarlık()
Cells.Borders(xlDiagonalDown).LineStyle = xlNone
  Cells.Borders(xlDiagonalUp).LineStyle = xlNone
   Cells.Borders(xlInsideVertical).LineStyle = xlNone
Cells.Borders(xlInsideHorizontal).LineStyle = xlNone

With Range("A1:H" & Cells(Rows.Count, 1).End(3).Row)
.Borders(xlLeft).LineStyle = xlContinuous
.Borders(xlTop).LineStyle = xlContinuous
.Borders(xlBottom).LineStyle = xlContinuous
.Borders(xlRight).LineStyle = xlContinuous
    End With
End Sub

Kodlarınızı bu şekilde deneyin.
Koşullu ile olmuyor.
 
Alternatif,

Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error Resume Next
    Application.ScreenUpdating = False
    If Application.CutCopyMode = xlCopy Then Exit Sub
    If Application.CutCopyMode = xlCut Then Exit Sub
    Cells.FormatConditions.Delete
    Range("J1") = 1
    With Range("A" & Target.Row).Resize(1, 8)
        .FormatConditions.Add xlExpression, , "=$J$1=1"
        .FormatConditions(1).Borders.LineStyle = 1
        .FormatConditions(1).Interior.ColorIndex = 6
        .FormatConditions(1).Font.Bold = True
        .FormatConditions(1).Font.ColorIndex = 3
    End With
    Range("A:H").FormatConditions.Add xlExpression, , "=$A1<>"""""
    Range("A:H").FormatConditions(2).Borders.LineStyle = 1
    Application.ScreenUpdating = True
End Sub
 
Sayın Ömer Bey, Sayın Acar ve Korhan Bey ilginize çok teşekkür ederim, tam istediğim gibi oldu, her üç kodda güzel çalışıyor sizleri uğraştırdım kusura bakmayın.

Hayırlı geceler.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst