• DİKKAT

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

Satır başlıkları renklendirmek

D

dbicer83

Katılım
29 Kasım 2007
Mesajlar
332
Excel Vers. ve Dili
Office2003
Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Sütun_1 As String, Sütun_2 As String, X As Byte

If Application.CutCopyMode = xlCopy Or Application.CutCopyMode = xlCut Then Exit Sub
Range("D4:AB4").Interior.ColorIndex = 47
If Intersect(Target, [D:AB]) Is Nothing Then Exit Sub
If Target.Cells.Count = 16777216 Then Exit Sub

If InStr(1, Target.Address(0, 0), ":") > 0 Then
Sütun_1 = Split(Target.Address(0, 0), ":")(0)
Sütun_2 = Split(Target.Address(0, 0), ":")(1)

For X = 0 To 9
Sütun_1 = Replace(Sütun_1, X, "")
Sütun_2 = Replace(Sütun_2, X, "")
Next

If Cells(4, Sütun_1).Column < 4 And Cells(4, Sütun_2).Column > 28 Then
Range(Cells(4, "D"), Cells(4, "AB")).Interior.ColorIndex = 3
ElseIf Cells(4, Sütun_1).Column < 4 And Cells(4, Sütun_2).Column < 29 Then
Range(Cells(4, "D"), Cells(4, Sütun_2)).Interior.ColorIndex = 3
ElseIf Cells(4, Sütun_1).Column > 3 And Cells(4, Sütun_2).Column > 28 Then
Range(Cells(4, Sütun_1), Cells(4, "AB")).Interior.ColorIndex = 3
Else
Range(Cells(4, Sütun_1), Cells(4, Sütun_2)).Interior.ColorIndex = 3
End If

Else

If Target.Column > 3 Or Target.Column < 29 Then Cells(4, Target.Column).Interior.ColorIndex = 3

End If
End Sub

Bu kodu satırlar için uygulatmak istiyorum ama yapamadım yardımcı oalbilirmisiniz.
 
birden fazla hücreyi içeren bir alan seçildiğinde bu alanın başlangıç ve bitiş sütun numarasına göre işlem yapılıyor. doğru anlamışımdır umarım.

önce sizin kodu sadeleştirelim.

Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim TR&, BR&, LC%, RC%

If Application.CutCopyMode = xlCopy Or Application.CutCopyMode = xlCut Then Exit Sub
If Intersect(Target, [A:AD]) Is Nothing Then Exit Sub
If Target.Cells.Count = 16777216 Then Exit Sub

Range("D4:AB4").Interior.ColorIndex = 47

If Target.Count > 1 Then
    With Target
        TR = .Row
        BR = .Rows.Count + .Row - 1
        LC = .Column
        RC = .Columns.Count + .Column - 1
    End With
    If LC < 4 And RC > 28 Then
        Range("D4:AB4").Interior.ColorIndex = 3
    ElseIf LC < 4 And RC < 29 Then
        Range(Cells(4, "D"), Cells(4, RC)).Interior.ColorIndex = 3
    ElseIf LC > 3 And RC > 28 Then
        Range(Cells(4, LC), Cells(4, "AB")).Interior.ColorIndex = 3
    Else
        Range(Cells(4, LC), Cells(4, RC)).Interior.ColorIndex = 3
    End If
Else
    If Target.Column > 3 Or Target.Column < 29 Then Cells(4, Target.Column).Interior.ColorIndex = 3
End If

End Sub
 
Son düzenleme:
birden fazla hücreyi içeren bir alan seçildiğinde bu alanın başlangıç ve bitiş satır numarasına uyarlamaya çalışalım.

Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim TR&, BR&, LC%, RC%

If Application.CutCopyMode = xlCopy Or Application.CutCopyMode = xlCut Then Exit Sub
If Intersect(Target, [A:AD]) Is Nothing Then Exit Sub
If Target.Cells.Count = 16777216 Then Exit Sub

Range("B5:B50").Interior.ColorIndex = 47

If Target.Count > 1 Then
    With Target
        TR = .Row
        BR = .Rows.Count + .Row - 1
        LC = .Column
        RC = .Columns.Count + .Column - 1
    End With
    If TR < 5 And BR > 51 Then
        Range("B5:B50").Interior.ColorIndex = 3
    ElseIf TR < 4 And BR < 51 Then
        Range(Cells(5, 2), Cells(BR, 2)).Interior.ColorIndex = 3
    ElseIf TR > 4 And BR > 50 Then
        Range(Cells(TR, 2), Cells(BR, 2)).Interior.ColorIndex = 3
    Else
        Range(Cells(TR, 2), Cells(BR, 2)).Interior.ColorIndex = 3
    End If
Else
    If Target.Row > 4 Or Target.Row < 51 Then Cells(Target.Row, 2).Interior.ColorIndex = 3
End If

End Sub
 
Son düzenleme:
1. kod sizin ilk mesajdaki kodu ile yanı işlevi görür. daha sade halidir. (sütun numaralarının hatalı ise düzeltilmesi gerekebilir. hızlı hızlı yazdım çünkü.)

2. kod ise 1.kodun sütunda yaptığı işin satıra uyarlanmış halidir. Yani sizin sorunuza asıl cevap bu 2. kod.
 
Range("B5:B50").Interior.ColorIndex = 47
buradaki 47: koduna RGB 234,234,234 karşılık gelen renk kodu kaç kullanabiliriz 15 denedim biraz daha koyu bir renk çıktı.
 
aşağıdaki şekilde deneyebilirsiniz.
Kod: 
Range("B5:B50").Interior.Color = RGB(234, 234, 234)


RGB(234, 234, 234) karşılık gelen renk ise beyaz. yani şu da aynı işi görür.
Kod: 
Range("B5:B50").Interior.ColorIndex = 2
 
mancubus' Alıntı:
aşağıdaki şekilde deneyebilirsiniz.
Kod: 
Range("B5:B50").Interior.Color = RGB(234, 234, 234)


RGB(234, 234, 234) karşılık gelen renk ise beyaz. yani şu da aynı işi görür.
Kod: 
Range("B5:B50").Interior.ColorIndex = 2
Genişletmek için tıkla ...

Biraz koyu beyaz

Kod: 
Range("B5:B50").Interior.Color = RGB(234, 234, 234)
kodu ile hata veriyor.
 
kod bende sorunsuz çalışıyor.

fildişi için
Kod: 
Range("B5:B50").Interior.ColorIndex = 19

buz mavisi için
Kod: 
Range("B5:B50").Interior.ColorIndex = 24
 
Kodların anlamlarını ne işe yaradıklarını özet geçmemiz kod okuması yapmamız mümkünmüdür?
 
Interior = seçili olan veya belirtilen aralığın, hücrenin dolgusu ile ilgili işlem yapmak için.
ColorIndex: kendisinden önce gelen özelliğin renk index'idir.

Range("B5:B50").Interior.ColorIndex = 3 ile dolgu rengi kırmızı olur.
Range("B5:B50").Font.ColorIndex = 3 ile yazı rengi kırmızı olur.
 
Vermiş olduğunuz kodları kendi dosyama uyarlamay çalıştım ama işin içinden çıkamadım büyüktür küçüktür olayı kafamı karıştırdı satır satır kod okuması yaparsanız. Çok yardımcı olmuş olacaksınız. Şimdiden ilginizden dolayı teşekkürler.
Ayrıca belirlenen kısmın dışına çıkıldığı zaman hiç kırmızı seçme işlemi yapılmasın.
 
Son düzenleme:
ben örnek olarak vermiştim.
tam olarak ne istiyorsunuz detaylandırın yardımcı olmaya gayret edelim.

örnek:
a) C5:G10000 aralığında birden çok hücre seçildiğinde;
- sütun no 5-20 arasında ise 4. satır dolgu rengi alsın renk kodu 3 olsun.
- satır no 3-45 arasında ise 2. sütun dolgu rengi alsın renk kodu 6 olsun.
b) C5:G10000 aralığında bir hücre seçildiğinde;
- 4. satır dolgu rengi alsın renk kodu 3 olsun.
- 2. sütun dolgu rengi alsın renk kodu 6 olsun.


veya sadece örnekteki sütun uygulamasının satıra uyarlanması yeterli mi?
yine aktif hücre veya seçili alan hangi satırlar arasında kalır ise hangi sütunda renklendirme olsun?
 
Sizin kod mantığı daha sade görünüyor.
İstediğim,
F8:AS1190 aralığında hücre/hücreler seçili iken E8:E1190 hücre aralığın seçilen hücre/lerin karşılığı kırmızı olacak bu aralığın dışın bir hücre/hücreler seçildiğinde aynı renk sabit kalıp değişmiyecek.
Teşekkürler.
 
aşağıdakini bir deneyin

F8:AS1190 dışında bir hücre seçildiğinde E sütunundaki dolgu renginin kalkmasi için Range("E8:E1190").Interior.ColorIndex = xlNone satırını ekledim. E sütunundaki renk her zaman kalsın derseniz bu satırı silin.

hemen altında Range("E8:E1190").Interior.ColorIndex = 8 satırı ile ben rengi Turkuaz olarak belirledim. siz sevkinize göre değiştirebilirsiniz.

Çoklu hücre seçiminde alanın üst satır numarasının 8'den küçük veya 1190'dan büyük olması durumunda E sütununda sadece 8-1190 arasındaki satırlara isabet eden bölüm kırmızı oluyor.

Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim Ust_Sat&, Alt_Sat&

If Intersect(Target, Range("F8:AS1190")) Is Nothing Then
    Range("E8:E1190").Interior.ColorIndex = xlNone
    Exit Sub
Else
    Range("E8:E1190").Interior.ColorIndex = 8
End If

If Target.Count > 1 Then
    With Target
        Ust_Sat = .Row
        Alt_Sat = .Rows.Count + .Row - 1
    End With
    If Ust_Sat < 8 And Alt_Sat < 1191 Then
        Range(Cells(8, 5), Cells(Alt_Sat, 5)).Interior.ColorIndex = 3
    ElseIf Ust_Sat < 8 And Alt_Sat > 1190 Then
        Range(Cells(8, 5), Cells(1190, 5)).Interior.ColorIndex = 3
    ElseIf Ust_Sat > 7 And Alt_Sat > 1190 Then
        Range(Cells(Ust_Sat, 5), Cells(1190, 5)).Interior.ColorIndex = 3
    Else
        Range(Cells(Ust_Sat, 5), Cells(Alt_Sat, 5)).Interior.ColorIndex = 3
    End If
Else
    If Target.Row < 8 Or Target.Row > 1190 Then
        Exit Sub
    Else
    Cells(Target.Row, 5).Interior.ColorIndex = 3
    End If
End If

End Sub
 
Son düzenleme:
Aynısını sütün için yaparsak sorun çözüme kavuşmuştur işlemlerim gerçekten çok kolaylaştı sayenizde.
Emeğinize ve ilminize sağlık.
Teşekkürler.
 
rica ederim.

15 no.lu mesajdaki talebinize 16 no.lu mesajdaki kod cevap vermiyor mu?

ilave bir durum var ise detaylı anlatmanız gerekir.
 
Çözüldü sıkıntılı durum yok dün geç saatlere kadar dosyalara monte ettim süper oldu.
 
Fakat şöyle bir sıkıntıyı gördüm kopyala yapıştır devre dışı bırakılmış durumda etkin hale getirmek için ne yapmak gerek.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst