Hücre Değerine Göre Satırı Boyama

[fkorkmaz]

Merhaba, formda birçok buna benzer konu var ancak tam istediğimi bulamadım.

Ben J sütunundaki değerlerin 0'dan küçük olması durumunda, o hücreye ait satırdaki metinlerin tamamının kırmızı renge dönmesini istiyorum. Bunu makro ile yapabilersek sevinirim.

Teşekkürler.

 

[PLİNT]

Merhaba, formda birçok buna benzer konu var ancak tam istediğimi bulamadım.
Ben J sütunundaki değerlerin 0'dan küçük olması durumunda, o hücreye ait satırdaki metinlerin tamamının kırmızı renge dönmesini istiyorum. Bunu makro ile yapabilersek sevinirim.
Teşekkürler.

Merhaba
"J" sütununa rakamlar formüllemi geliyor, bir örnek ekleyip; indirme adresini
verirseniz:http://s3.dosya.tc/

 

[fkorkmaz]

Merhaba PLİNT, ilgilendiğin için teşekkür ederim. Örnek dosya linkte mevcut

http://s3.dosya.tc/server6/agu1yl/Genel_Is_Durumu.rar.html

 

[PLİNT]

Merhaba
Ek dosyayı inceleyiniz: http://s3.dosya.tc/server6/qlmzzj/Genel_Is_Durumu.rar.html


"Modül1" kod sayfası:

 Sub renk()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set s1 = Sheets("Genel İş Durumu")
s1.Cells.Font.ColorIndex = xlAutomatic
sat = s1.Cells(Rows.Count, "M").End(3).Row
say = WorksheetFunction.CountIf(s1.Range("m1:m" & sat), "<=0")
If say > 0 Then
For a = 1 To WorksheetFunction.CountIf(s1.Range("m1:m" & sat), "<=0")
If s1.Cells(a + 1, "m").Interior.ColorIndex = xlNone Then Range("a" & a + 1 & ":m" & a + 1).Font.ColorIndex = 3
Next
End If
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Sub ONAY()
    Set S0 = ActiveSheet
    Set CHK = S0.CheckBoxes(Application.Caller)
    i = CHK.TopLeftCell.Row
    j = CHK.TopLeftCell.Column
    Select Case CHK.Value
        Case 1
       For Each cb In S0.CheckBoxes
If CHK.Name <> cb.Name And i = cb.TopLeftCell.Row Then
S0.Shapes(cb.Name).ControlFormat.Value = xlOff
Exit For
End If
Next
             
S0.Range(S0.Cells(i, "A"), S0.Cells(i, j + 1)).Interior.Color = RGB(0, 75, 400)
S0.Range(S0.Cells(i, "A"), S0.Cells(i, j + 1)).Font.ColorIndex = xlAutomatic
        Case Else
            S0.Range(S0.Cells(i, "A"), S0.Cells(i, j + 1)).Interior.ColorIndex = Null
If Cells(i, "m") <= 0 Then S0.Range(S0.Cells(i, "A"), S0.Cells(i, j + 1)).Font.ColorIndex = 3
    End Select
End Sub
Sub RED()
    Set S0 = ActiveSheet
    Set CHK = S0.CheckBoxes(Application.Caller)
    i = CHK.TopLeftCell.Row
    j = CHK.TopLeftCell.Column
    Select Case CHK.Value
        Case 1
       For Each cb In S0.CheckBoxes
If CHK.Name <> cb.Name And i = cb.TopLeftCell.Row Then
S0.Shapes(cb.Name).ControlFormat.Value = xlOff
Exit For
End If
Next
S0.Range(S0.Cells(i, "A"), S0.Cells(i, j + 1)).Font.ColorIndex = xlAutomatic
            S0.Range(S0.Cells(i, "A"), S0.Cells(i, j)).Interior.Color = RGB(200, 75, 0)
        Case Else
            S0.Range(S0.Cells(i, "A"), S0.Cells(i, j)).Interior.ColorIndex = Null
 If Cells(i, "m") <= 0 Then S0.Range(S0.Cells(i, "A"), S0.Cells(i, j)).Font.ColorIndex = 3
    End Select
End Sub

"Sayfa1" (Genel İş Durumu) kod sayfası

Private Sub Worksheet_Change(ByVal Target As Range)
If Selection.Cells.Count > 1 Then
If Not Intersect(Range(Selection.Cells.Address), Columns("j")) Is Nothing Then
Application.EnableEvents = False
For a = 2 To Cells(Rows.Count, "j").End(3).Row
    If Cells(a, "J") = "" Then
        Cells(a, "M") = ""
    Else
 If IsDate(Cells(a, "j")) = True Then Cells(a, "M") = Cells(a, "J") - Date
    End If
    Next
Application.EnableEvents = True
    End If: End If
If Not Intersect(Target, [J:J]) Is Nothing Then
If IsDate(Cells(Target.Row, "j")) = True Then
 Cells(Target.Row, "M") = Cells(Target.Row, "J") - Date
 Cells(ActiveCell.Row, "M") = Cells(ActiveCell.Row, "J") - Date
 Else
 Cells(Target.Row, "M") = ""
If Cells(Target.Row, "J") <> "" Then MsgBox "GİRİLEN DEĞER TARİH DEĞİL"
 End If
    [A2:O5000].Sort [M2], xlAscending
End If
 Run ("renk")
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 13 Then Cells(2, 12).Select
End Sub

 

[fkorkmaz]

Merhaba PLİNT, öncelikle ellerine sağlık, çok teşekkür ederim. Acaba hücre dolgusunu değilde yazının rengini değiştirmek için nasıl bir değişiklik yapmamız gerekiyor?

 

[PLİNT]

Merhaba PLİNT, öncelikle ellerine sağlık, çok teşekkür ederim. Acaba hücre dolgusunu değilde yazının rengini değiştirmek için nasıl bir değişiklik yapmamız gerekiyor?

Merhaba
Yukarıdaki değişen kodları ve dosyayı inceleyiniz.
"Değişen kodlar" dediğimden kastım önceki dosyada kod başlığı olupta
içine yaptığım ('................ ) aralarındaki eklemelerdir.
"Sub auto_open" ve "sub renk" başlıklarını ben eklemiştim.

 

[fkorkmaz]

Merhaba PLINT, satırlarda kes yapıştır yaptığımda boyalı olan satırlar o şekilde kalıyor. Birde dolguyu değil de satırda yazan yazıları boyama şansımız var mı acaba

 

[PLİNT]

Merhaba PLINT, satırlarda kes yapıştır yaptığımda boyalı olan satırlar o şekilde kalıyor. Birde dolguyu değil de satırda yazan yazıları boyama şansımız var mı acaba

Merhaba
Kes yapıştırda işlem yapmaması kodların; sadece "J" sütununa veri girişiyle
çalışması sağlandığı içindi,
Yukarıdaki dosya ve kodların hepsi değişti inceleyin. "<=0" haline uygundur.