• DİKKAT

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

Satır renklendirme

R

rapstar_kagan_96

Banned
Katılım
12 Temmuz 2010
Mesajlar
86
Excel Vers. ve Dili
Excel 2003 / Türkçe
Arkadaşlar merhaba.
Konu ile ilgili çok örnek var ama benim isteğimi karşılayanı bulamadığım için buraya yazmaya karar verdim.
Çalışma kitabımın içerisinde en az 20 çalışma sayfası var.Bu sayfalarda A:F sütunları arasında çizelgeler var. İsteğim şu:
Her sayfanın A2 hücresinden başlamak üzere sadece dolu satırların (A:F sütunları arasında) açık sarı-açık turkuaz şeklinde satır satır renklenmesini istiyorum.
Yani;
A2:F2 açık sarı
A3:F3 açık turkuaz
A4:F4 açık sarı
A5:F5 açık turkuaz …….şeklinde.
Kolaylık olsun diye şöyle de diyebiliriz. Çift satırlar açık sarı,tek satırlar açık turkuaz.
Bazı sayfalar onlarca satır olabiliyor,bazı sayfalar ise sadece 1-2 satır olabiliyor. Dediğim gibi isteğim sadece dolu satırların renklenmesi.
Şimdiden teşekkürler.
 
1. "a2: f2" seç ; Tablo olarak biçimlendiri tıkla ; yeni tablo biçimine gir ; ilk satır biçimlendirme sarı; ikinci satır şeridi turkuaz, bitti alttan çekip uzatabilirsiniz.

sonraki sayfalar için sadece a2:f2 seçin tablodan yeni yaptıgınız tabloyu seçin.
 
snx111 arkadaşım.Öncelikle ilginize teşekkür ediyorum. Fakat benim excel versiyonum 2003 Türkçe. Bu dediklerinizi hiçbir menüde bulamadım. Acaba ben mi bulamadım, yoksa sizin anlattıklarınız 2007 için mi geçerli?
 
ben 2010 kullanıyorum 2003 2007 hayatımda kullanmadım vardır bi yerlerinde belki bilmiyorum ; 2010 nu neden yüklemiyorsunuz ?
 
. . .

Kod: 
Sub kod_bir()
Application.ScreenUpdating = False
aa = [a65536].End(3).Row
Range("a2:f65536").Interior.ColorIndex = xlNone

For i = 2 To aa
If Range("a" & i) <> "" Then
Range("a" & i & ":f" & i).Interior.ColorIndex = 6
Else
End If
Next i

For a = 0 To aa
a = a + 1
If Range("a" & a) <> "" Then
Range("a" & a & ":f" & a).Interior.ColorIndex = 8
Else
End If
Next a

Application.ScreenUpdating = True
End Sub

. .
 
Hüseyin kardeş. Senin de ilgine ve emeğine teşekkür ediyorum. İstediğim gibi olmuş.Bu konu ile ilgili ufak bir ricam olacak. Birincisi şu :
Ben verdiğiniz kodları butona atayıp çalıştırdım.Kodları butonsuz çalıştırmanın yolu var mı? Yani veri girdikçe kendi liğinden renklendirebilir mi?
 
. . .

Yapılabilir.
Veri girişi yaptğınız alan A:F arası mı ?
Yoksa veri girişi yapılan sütun veya sütunlar farklı mı ?

. . .
 
Bu alana veri girişi yapmıyorum.Veriler başka sayfadan makro aracılığı ile aktarılıyor. Ama alan, aynı alan.A2:F arası yani.
 
Hemen bir ilave yapmak istiyorum. Şimdi dikkatimi çekti.. Sizin gönderdiğiniz ilk kodlarda başlık satırını da (yani A1:F1 arasını) sizin kodlarla renklendiriyor. Oysa orası başlık satırı ve rengi başka. Ufak bir ricam daha olacak. Renk kodları; açık sarı(36) ve açık mavi(34) kodlu olacak.
 
veri girdikçe renklendirmek iyi olmaz performansı çok düşürür...
 
Son düzenleme:
rapstar_kagan_96' Alıntı:
Bu alana veri girişi yapmıyorum.Veriler başka sayfadan makro aracılığı ile aktarılıyor. Ama alan, aynı alan.A2:F arası yani.
Genişletmek için tıkla ...
. . .

Bu kısmı anlamadım.
Örneğin, sayfa1 de veri girişi yapacaksınız, diğer sayfalarda aynı anda renkendirme mi yapacak?

. . .

Hemen bir ilave yapmak istiyorum. Şimdi dikkatimi çekti.. Sizin gönderdiğiniz ilk kodlarda başlık satırını da (yani A1:F1 arasını) sizin kodlarla renklendiriyor. Oysa orası başlık satırı ve rengi başka. Ufak bir ricam daha olacak. Renk kodları; açık sarı(36) ve açık mavi(34) kodlu olacak.
Genişletmek için tıkla ...

. . .

Kod: 
Sub kod_bir()
Application.ScreenUpdating = False
aa = [a65536].End(3).Row
Range("a2:f65536").Interior.ColorIndex = xlNone

For i = 2 To aa
If Range("a" & i) <> "" Then
Range("a" & i & ":f" & i).Interior.ColorIndex = 36
Else
End If
Next i

For a = 2 To aa
a = a + 1
If Range("a" & a) <> "" Then
Range("a" & a & ":f" & a).Interior.ColorIndex = 34
Else
End If
Next a

Application.ScreenUpdating = True
End Sub

. . .
 
Dostum teşekkürler.Butona atayıp denedim oldu. İlk çözümde de anımsatmıştım sanırım unuttunuz.(Ya da ben yapamadım) Butonla değil de veri girdikçe renklense olabilir mi?Gelelim sorunuza :
"Data" isimli bir sayfam var. Bu sayfaya hata bildirimleri geldikçe işliyorum. İşledikten sonra bu sayfa üzerinde bulunan buton aracılığıyla ilgili hata sayfalarına aktarıyorum. Eğer, yeni bir hata geldiyse bu data sayfasına işlediğim hata ismiyle yeni bir sayfa açıyor ve renklendiriyor. Ama her seferinde renklendirme karışıyor. Şimdi yaptığım denemede de öyle oldu. Sayfaya yeni veri girdikten sonra aktardım mı renkler yine karışıyr.Sizin kodları atadığım butona bastım mı renklendirme düzeliyor. Benim sizden isteğim de bunun yüzendendi zaten.. Data sayfasına veriler girilip aktar butonuna bastım mı karışıklık yaşanmamalı.. Ben size butonlardaki kodları göndereyim madem.
DATA" sayfasında bulunan "aktar" butonu kodları şöyle :

Private Sub Image2_Click()
Sheets("DATA").Unprotect Password:="6166"
Application.ScreenUpdating = False
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = ThisWorkbook.Worksheets("DATA")
'Application.DisplayAlerts = False
'For Each Sh In ThisWorkbook.Worksheets
' If Sh.Name <> s1.Name Then Sh.Delete
'Next
'y:

For x = 1 To Worksheets.Count
If Worksheets(x).Name = "DATA" Or Worksheets(x).Name = "Grafik Sayfası" Then GoTo Hata
Worksheets(x).AutoFilterMode = False
Worksheets(x).Range("2:5536").Delete 'sayfaları silmek yerine içeriğini siliyorum
'GoTo y:
Hata:
Next x
'Application.DisplayAlerts = True
s1.AutoFilterMode = False
Call s1.Range("E:E").AdvancedFilter(xlFilterCopy, , s1.Range("Z1"), True)
s = s1.Range("Z5000").End(xlUp).Row
'For i = 2 To s1.Range("Z5000").End(3).Row
'If s1.Range("Z" & i).Value <> Empty Then
'Sheets.Add.Name = s1.Range("Z" & i).Value
's1.Range("A1:F1").Copy ActiveSheet.Range("A1")
'Next i
Call aktar
s1.Select
Application.ScreenUpdating = True
Sheets("DATA").Protect Password:="6166"
End Sub

Ayrıca,bu verilerle oluşturduğum bir de grafik sayfası var.Bu sayfaya da aktarma kodları şöyle :

Sub aktar()
Set s1 = ThisWorkbook.Worksheets("DATA")

For i = 2 To s1.Rows.Count
If s1.Cells(i, 1) = "" Then Exit For

sayfabulundu = False

'Set s2 = ThisWorkbook.Worksheets(s1.Cells(i, 5).Value)
For Each Sh In ThisWorkbook.Worksheets
If Sh.Name = s1.Range("E" & i).Value Then
sayfabulundu = True
s1.Range("A" & i & ":F" & i).Copy
Sheets(Sh.Name).Activate
ActiveSheet.Range("A5000").End(3)(2, 1).Activate
ActiveSheet.Paste
End If
Next

If Not sayfabulundu Then
Set Sh = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Worksheets("Grafik Sayfası"))
s1.Range("A1:F1").Copy Sh.Range("A1")
Sh.Name = s1.Cells(i, 5).Value
s1.Range("A" & i & ":F" & i).Copy
Sheets(Sh.Name).Activate
ActiveSheet.Range("A5000").End(3)(2, 1).Activate

ActiveSheet.Paste

End If

'Set s2 = Nothing
Next i
End Sub

Tekrar teşekkürler.
 
Son düzenleme:
Şunu demek istiyorum. Her sayfaya bu kodları kaydedip ,her sayfaya buton eklemektense data sayfasından , ya da bir modüle ekleyip bu renklendirmeyi sağlamanın yolu var mı?
 
. . .

Daha önce verdiğim kodları boş modüle kopyalayın.

Mevcut kodlarınızı aşağıdakiler ile değiştirerek deneyiniz.
Not: Örnek dosya olmadığı için, net çözüm veremiyorum. Kodlarda duruma göre revizeler yapmak zorunda kalabilirsiniz.

Kod: 
Private Sub Image2_Click()
Sheets("DATA").Unprotect Password:="6166"
Application.ScreenUpdating = False
h1 = Sheets.Count
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = ThisWorkbook.Worksheets("DATA")
'Application.DisplayAlerts = False
'For Each Sh In ThisWorkbook.Worksheets
' If Sh.Name <> s1.Name Then Sh.Delete
'Next
'y:

For x = 1 To Worksheets.Count
If Worksheets(x).Name = "DATA" Or Worksheets(x).Name = "Grafik Sayfası" Then GoTo Hata
Worksheets(x).AutoFilterMode = False
Worksheets(x).Range("2:5536").Delete 'sayfaları silmek yerine içeriğini siliyorum
'GoTo y:
Hata:
Next x
'Application.DisplayAlerts = True
s1.AutoFilterMode = False
Call s1.Range("E:E").AdvancedFilter(xlFilterCopy, , s1.Range("Z1"), True)
s = s1.Range("Z5000").End(xlUp).Row
'For i = 2 To s1.Range("Z5000").End(3).Row
'If s1.Range("Z" & i).Value <> Empty Then
'Sheets.Add.Name = s1.Range("Z" & i).Value
's1.Range("A1:F1").Copy ActiveSheet.Range("A1")
'Next i
Call aktar
s1.Select

For h2 = 2 To h1
Sheets(h2).Select
Call kod_bir
Next h2

Application.ScreenUpdating = True
Sheets("DATA").Protect Password:="6166"
End Sub

. . .
 
Renklendirme süper oldu ama diğer kodlarda ortalık bir hayli karıştı.. Kimi hata bildiriminden aynı sayfaya, aynı parça numarası ve hata kodu ile 25 adet birden işlendi.
 
2010 download etmek neden bu kadar zor ? 30 günlük betası var ; onunda çözümü sitelerde var ...
 
Merhaba,

İstediğiniz işlemi koşullu biçimlendirme ile rahatlıkla yapabilirsiniz.

Ekteki örnek dosyayı inceleyin. Kendi dosyanıza uyarlamak için A:F sütununlarını seçip kopyala komutunu çalıştırın. Daha sonra kendi dosyanıza geçin. İstediğiniz sayfanın A:F aralığını seçip ÖZEL YAPIŞTIR-BİÇİMLERİ komutunu çalıştırın.
 

Ekli dosyalar

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