• DİKKAT

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

Sayfa sekmelerini renklendirmek

pristineli45

Banned
Katılım
31 Aralık 2012
Mesajlar
130
Excel Vers. ve Dili
Excel2003 Türkçe
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
 
. . .

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.

Kod:
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.

. . .
 
Son düzenleme:
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(y).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,O1:P1").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 & ":P" & x).Copy Sheets(Sayfa).Range("H" & s)
Sheets(Sayfa).Range("A:P").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
 
Son düzenleme:
. . .

# 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.
Kod:
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.

. . .
 
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.
 
. . .

2 seçenek mevcut.

Kodların sonuna Veri Tabanı sayfasını kırmızı yap kodlarını ilave edebilirsiniz.
Kod:
ActiveWorkbook.Sheets(""Veri Tabanı).Tab.ColorIndex = 3

veya

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

Kod:
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

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