Sayfa sekmelerini renklendirmek

[pristineli45]

Arkadaşlar merhaba.
Sayfa sekmelerinin otomatik olarak renklenmesini istiyorum.
Renklendirmenin; bir sayfa sarı (renk kodu:36), diğer sayfa mavi (renk kodu:34) şeklinde olmasını istiyorum. Yalnız;dosya içerisinde onlarca sayfa var.Yeni sayfa eklendiğinde alfabetik olarak sıralanıyor. Sıralama değiştiğinde otomatik olarak sekme renkleri de değişmeli.Yani,sarı-mavi şeklinde yeniden düzenlenmeli.
Şimdiden teşekkürler

 

[Emir Hüseyin Çoban]

. . .

Kodları boş bir modüle ekleyin. Excel 2007 ve üstü sürümler için.
Daha sonra alfabetik sıralama yapan kodların sonuna Call KOD_2007 komutunu ekleyin.

Sub KOD_2007()
Application.ScreenUpdating = False

For i = 1 To Sheets.Count
If WorksheetFunction.ISEVEN(i) = True Then
ActiveWorkbook.Sheets(i).Tab.ColorIndex = 36
Else
ActiveWorkbook.Sheets(i).Tab.ColorIndex = 33
End If
Next i

Application.ScreenUpdating = True
MsgBox " B i t t i "
End Sub

Düzeltme: Kodun çalışma sürümleri belirtildi.

. . .

 

[pristineli45]

Hüseyin kardeş.
Öncelikle ilginizi ve emeğinize teşekkür ediyorum.Dediklerinizi uyguladım fakat sonuç alamadım.(Hatanın benden kaynaklandığı kesin.)
If WorksheetFunction.ISEVEN(i) = True Then
satırında hata veriyor
Ben size, sayfa dağıtmayı ve sıralamayı yapan kodları ekliyorum. Bunun üzerinde eklemeyi yşaparsanız çok sevinirim. Çünkü sayfa üzerinde zaten 2 tane buton var,bir de bu üçüncü butonu ekleyip görüntü kirliliğine yol açmak istemiyorum. Sizin kodları bu kodları tek butona yerleştirebilirseniz harika olur. Tekrar teşekkür ederim.
Kodlar şöyle :

Sub Sayfalara_att()
Application.ScreenUpdating = False
On Error Resume Next
Dim x, y As Long, Sayfa As String, S1 As Worksheet
Set S1 = Sheets("Veri tabanı")
Application.ScreenUpdating = False
For y = 2 To Worksheets.Count
Sheets.Cells.Delete Shift:=xlUp
Next y
For x = 2 To S1.[b65536].End(3).Row
Sayfa = Cells(x, "n")
If Not Sayfakontrol(Sayfa) Then
Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Sayfa
S1.Select
End If
S1.Range("A1:G1,O11").Copy
Sheets(Sayfa).Range("A1").PasteSpecial (xlPasteFormats)
Sheets(Sayfa).Range("A1").PasteSpecial (xlPasteValues)


s = Sheets(Sayfa).[A65536].End(3).Row + 1




S1.Range("A" & x & ":G" & x).Copy Sheets(Sayfa).Range("A" & s)
S1.Range("O" & x & "" & x).Copy Sheets(Sayfa).Range("H" & s)
Sheets(Sayfa).Range("A").EntireColumn.AutoFit
Next x
Set S1 = Nothing
Application.ScreenUpdating = True
Dim i As Integer, _
j As Integer

If Worksheets.Count < 1 Then Exit Sub

With Application
.Calculation = xlManual
.ScreenUpdating = False
End With

Sayfa = Application.ActiveSheet.Name
If Worksheets.Count = 1 Then Exit Sub
For i = 2 To Worksheets.Count - 1
For j = i + 1 To Worksheets.Count
If Worksheets(j).Name < Worksheets(i).Name Then
Worksheets(j).Move Before:=Worksheets(i)
End If
Next j
Next i
Worksheets(Sayfa).Activate

Worksheets("Veri tabanı").Select


End Sub

 

[Emir Hüseyin Çoban]

. . .

# 2 nolu mesajımdaki kodlar 2007 ve üstü sürümlerde çalışacaktır.
Ben 2007 sürümünde hazırlayıp, test etmiştim.

2003 sürümü için şu kodları deneyiniz.

Sub KOD_2003()
Application.ScreenUpdating = False

For i = 1 To Sheets.Count
If WorksheetFunction.Odd(i) = i Then
ActiveWorkbook.Sheets(i).Tab.ColorIndex = 36
Else
ActiveWorkbook.Sheets(i).Tab.ColorIndex = 33
End If
Next i

Application.ScreenUpdating = True
MsgBox " B i t t i "
End Sub

Not: İletilerinizde kod bloglarını belirtirken code taglarını kullanının.
[code]Kodlarınız[/code]

Office 2013 çıktı, yavaş yavaş sürümlerinizi yükseltmenizi tavsiye edebilirim.

. . .

 

[pristineli45]

Hüseyin kardeş harika olmuş.
Çok ama çok özür dileyerek ufak bir ricam olacak. Size söylemeyi unuttum.
En başta sabit kalan "Veri tabanı" sayfasının sekme rengi kırmızı olacak (renk kodu:3) diğer sayfalar önceki mesajımda belirttiğim şekilde olacaktı. Tekrar özür diliyor,yardımlarınızı bekliyorum.

 

[Emir Hüseyin Çoban]

. . .

2 seçenek mevcut.

Kodların sonuna Veri Tabanı sayfasını kırmızı yap kodlarını ilave edebilirsiniz.

ActiveWorkbook.Sheets(""Veri Tabanı).Tab.ColorIndex = 3

veya

koşul ekleyerek sayfa ismi Veri Tabanı ise işlem yapma diyebiliriz.

Sub KOD_2003()
Application.ScreenUpdating = False

For i = 1 To Sheets.Count

[B]If Sheets(i).Name = "Veri tabanı" Then
Else[/B]

If WorksheetFunction.Odd(i) = i Then
ActiveWorkbook.Sheets(i).Tab.ColorIndex = 36
Else
ActiveWorkbook.Sheets(i).Tab.ColorIndex = 33
End If
[B]
End If[/B]
Next i

Application.ScreenUpdating = True
MsgBox " B i t t i "
End Sub

. . .

 

[pristineli45]

Tek kelime ile SÜPERRRRRRR...
Çok çok teşekkür...