Tekrarlanan verileri farklı renkte yapma

Katılım
9 Aralık 2009
Mesajlar
159
Excel Vers. ve Dili
Office 2016 TR 64 Bit
merhaba. normalde tekrarlanan verileri koşullu biçimlendirme ile yapılmakta gayet iyi bilmekteyim. Sizden ricam her tekrarlan veri farklı renkte olacak.

örnek
1. tekrarlanan sarı
2. tekrarlana mavi
.....

bu tarzda yapabilir miyiz.
 

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
5,803
Excel Vers. ve Dili
2019 Türkçe
Merhaba.
Koşullu biçimlendirme ile yapılabilir.

Biçimlendirme yapılacak alanın A sütunu olduğunu var sayarsak, sadece A2 hücresini seçin.
Koşullu Biçimlendirme / Yeni kural seçin.
Birinci kural için formül kullan seçin aşağıdaki formülü formül kısmına kopyalayın.
Kod:
=EĞERSAY(A$1:A2;A2)=1
Daha sonra 1. tekrar için gerekli biçimlendirme ayarlarını seçin.

Yeni Kural daha ekleyin formül kısmına aşağıdaki formülü kopyalayın.
Kod:
=EĞERSAY(A$1:A2;A2)=2
Daha sonra 2. tekrar için gerekli biçimlendirme ayarlarını seçin.

Yeni Kural daha ekleyin formül kısmına aşağıdaki formülü kopyalayın.
Kod:
=EĞERSAY(A$1:A2;A2)=3
Daha sonra 3. tekrar için gerekli biçimlendirme ayarlarını seçin.

Bu şekilde kural ekleyerek devam edebilirsiniz.

Kural ekleme bittikten sonra A2 hücresini kopyalayın A sütununu seçip, özel yapıştır, biçimler i seçin.
Tamamı tıklatın.
 
Katılım
9 Aralık 2009
Mesajlar
159
Excel Vers. ve Dili
Office 2016 TR 64 Bit
ilgi
Merhaba.
Koşullu biçimlendirme ile yapılabilir.

Biçimlendirme yapılacak alanın A sütunu olduğunu var sayarsak, sadece A2 hücresini seçin.
Koşullu Biçimlendirme / Yeni kural seçin.
Birinci kural için formül kullan seçin aşağıdaki formülü formül kısmına kopyalayın.
Kod:
=EĞERSAY(A$1:A2;A2)=1
Daha sonra 1. tekrar için gerekli biçimlendirme ayarlarını seçin.

Yeni Kural daha ekleyin formül kısmına aşağıdaki formülü kopyalayın.
Kod:
=EĞERSAY(A$1:A2;A2)=2
Daha sonra 2. tekrar için gerekli biçimlendirme ayarlarını seçin.

Yeni Kural daha ekleyin formül kısmına aşağıdaki formülü kopyalayın.
Kod:
=EĞERSAY(A$1:A2;A2)=3
Daha sonra 3. tekrar için gerekli biçimlendirme ayarlarını seçin.

Bu şekilde kural ekleyerek devam edebilirsiniz.

Kural ekleme bittikten sonra A2 hücresini kopyalayın A sütununu seçip, özel yapıştır, biçimler i seçin.
Tamamı tıklatın.

ilginiz için teşekkür ederim ama bende tekrarlayanlar baya fazla
 

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
5,803
Excel Vers. ve Dili
2019 Türkçe
İsterseniz aşağıdaki kodları bir butona ekleyerek çalıştırın.

Kod:
Sub TekrarlarıRenklendir()
    Dim Bak As Range
    Dim Renkler() As Variant
    Dim Say As Integer
    Renkler = Array(, rgbAliceBlue, rgbAntiqueWhite, rgbAqua, rgbAquamarine, rgbAzure, rgbBeige, rgbBeige, rgbBisque, rgbBlanchedAlmond, rgbBlueViolet, rgbBrown, rgbBurlyWood)
    For Each Bak In Range("A2:A" & Cells(Rows.Count, "A").End(3).Row)
        Say = WorksheetFunction.CountIf(Range("A2:" & Bak.Address), Bak.Text)
        Bak.Interior.Color = Renkler(Say)
    Next
End Sub
Yada isterseniz aşağıdaki kodları sayfanın kod kısmına yazın, hücrede her değişiklik olduğunda renklendirme yapsın
Kod:
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
    Dim Bak As Range
    Dim Renkler() As Variant
    Dim Say As Integer
    Renkler = Array(, rgbAliceBlue, rgbAntiqueWhite, rgbAqua, rgbAquamarine, rgbAzure, rgbBeige, rgbBeige, rgbBisque, rgbBlanchedAlmond, rgbBlueViolet, rgbBrown, rgbBurlyWood)
    For Each Bak In Range(Target.Address & ":A" & Cells(Rows.Count, "A").End(3).Row)
        Say = WorksheetFunction.CountIf(Range("A1:" & Bak.Address), Bak.Text)
        Bak.Interior.Color = Renkler(Say)
    Next
End Sub
Ben 12 adet renk ekledim. Eğer daha fazla tekrarlama olursa hata verecektir.
Daha fazla tekrarlama olacaksa siz sadece en fazla tekrralanma sayısı kadar Renkler = Array(, rgbAliceBlue, rgbAntiqueWhite,... satırına yeni renkler ekleyin.
 
Katılım
9 Aralık 2009
Mesajlar
159
Excel Vers. ve Dili
Office 2016 TR 64 Bit
Emeğinize sağlık öncelikle. ben sorunu anlatamadım sanırım . tekrar eden urun grubları farklı renklerde olsun istiyorum misal kalem kalem kalem kırmızı silgi silgi mavi kağıt kağıt kağıt turuncu. grublar farklı renkler olup ayrımını anlamak için istemiştim
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Kaç farklı ürün grubunuz var?
 
Katılım
6 Mart 2005
Mesajlar
6,238
Excel Vers. ve Dili
Excel Vers. ve Dili:
Office 2016 TR 64 Bit
Koşul sayfasında ürün rengi belirleyiniz.Belirlediğiniz renk olsun.
 

Ekli dosyalar

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Alternatif;

10.000 satır ve 1.000 farklı üründe aşağıdaki kodu denedim. 20-25 saniye civarında işlem sonuçlanıyor.

Kod:
Option Explicit

Sub Renklendir()
    Dim S1 As Worksheet, Dizi As Object, Urun As Variant, Say As Long
    Dim Son As Long, Veri As Variant, X As Long, Renkler As Object, Zaman As Double
    Dim Renk_Kodu_1 As Byte, Renk_Kodu_2 As Byte, Renk_Kodu_3 As Byte
   
    Zaman = Timer
   
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
   
    Set S1 = Sheets("Sheet1")
    Set Dizi = CreateObject("Scripting.Dictionary")
    Set Renkler = CreateObject("Scripting.Dictionary")
   
    On Error Resume Next
    S1.ShowAllData
    S1.Range("A2:A" & S1.Rows.Count).Interior.Color = xlNone
    On Error GoTo 0
   
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Veri = S1.Range("A2:A" & Son).Value
   
    For X = 1 To UBound(Veri, 1)
        Dizi(Veri(X, 1)) = 1
    Next
   
    For Each Urun In Dizi.Keys
        S1.Range("A1").AutoFilter 1, Urun
Tekrar: Randomize
        Renk_Kodu_1 = Int((255 - 1 + 1) * Rnd + 1)
        Renk_Kodu_2 = Int((255 - 1 + 1) * Rnd + 1)
        Renk_Kodu_3 = Int((255 - 1 + 1) * Rnd + 1)
        If Not Renkler.Exists(RGB(Renk_Kodu_1, Renk_Kodu_2, Renk_Kodu_3)) Then
            Renkler.Add RGB(Renk_Kodu_1, Renk_Kodu_2, Renk_Kodu_3), Nothing
            S1.Range("A2:A" & Son).SpecialCells(xlCellTypeVisible).Interior.Color = RGB(Renk_Kodu_1, Renk_Kodu_2, Renk_Kodu_3)
        Else
            Say = Say + 1
            GoTo Tekrar
        End If
    Next

    On Error Resume Next
    S1.ShowAllData
    On Error GoTo 0
   
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
   
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "Mükerrer renk sayısı ; " & Say & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
 

caytug

Altın Üye
Katılım
12 Şubat 2014
Mesajlar
47
Excel Vers. ve Dili
2003-2010
Alternatif;

10.000 satır ve 1.000 farklı üründe aşağıdaki kodu denedim. 20-25 saniye civarında işlem sonuçlanıyor.

[kod]
Seçenek Açık

Sub Renklendir()
Dim S1 Çalışma Sayfası, Dizi Nesne Olarak, Varyant Olarak Urun, Uzun Say
Dim Son As Long, Veri As Variant, X As Long, Renkler As Object, Zaman As Double
Dim Renk_Kodu_1 As Byte, Renk_Kodu_2 As Byte, Renk_Kodu_3 As Byte

Zaman = Timer

Uygulama ile
.ScreenUpdating = Yanlış
.Hesaplama = xlHesaplamaManuel
.EnableEvents = Yanlış
İle bitmek

Set S1 = Sayfalar("Sayfa1")
Set Dizi = CreateObject("Scripting.Dictionary")
Set Renkler = CreateObject("Scripting.Dictionary")

Hatada Devam Et Sonraki
S1.Tüm Verileri Göster
S1.Range("A2:A" & S1.Rows.Count).Interior.Color = xlYok
Hatada GoTo 0

Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
Veri = S1.Range("A2:A" & Son).Value

X = 1 için UBound(Veri, 1) için
Dizi(Veri(X, 1)) = 1
Sonraki

For Each Urun In Dizi.Keys
S1.Range("A1").Otomatik Filtre 1, Urun
Tekrar: Randomize
Renk_Kodu_1 = Int((255 - 1 + 1) * Rnd + 1)
Renk_Kodu_2 = Int((255 - 1 + 1) * Rnd + 1)
Renk_Kodu_3 = Int((255 - 1 + 1) * Rnd + 1)
If Not Renkler.Exists(RGB(Renk_Kodu_1, Renk_Kodu_2, Renk_Kodu_3)) Then
Renkler.Add RGB(Renk_Kodu_1, Renk_Kodu_2, Renk_Kodu_3), Nothing
S1.Range("A2:A" & Son).SpecialCells(xlCellTypeVisible).Interior.Color = RGB(Renk_Kodu_1, Renk_Kodu_2, Renk_Kodu_3)
Başka
Söyle = Söyle + 1
GoTo Tekrar
Bitir
Sonraki

Hatada Devam Et Sonraki
S1.Tüm Verileri Göster
Hatada GoTo 0

Uygulama ile
.ScreenUpdating = Doğru
.Hesaplama = xlHesaplamaOtomatik
.EnableEvents = Doğru
İle bitmek

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
"Mükerrer renk sayısı ; " & Say & Chr(10) & Chr(10) & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
Alt Bitiş
[/ kod]
Sayın korhan, tekrarlayan verileri rastgele değilde 2 sabit renkle renklendirmek mümkün mü?
 
Son düzenleme:

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

C++:
Option Explicit

Sub Renklendir()
    Dim S1 As Worksheet, Dizi As Object, Urun As Variant
    Dim Son As Long, Veri As Variant, X As Long
    Dim Renk As Byte, Say As Long, Zaman As Double
   
    Zaman = Timer
   
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
   
    Set S1 = Sheets("Sheet1")
    Set Dizi = CreateObject("Scripting.Dictionary")
   
    On Error Resume Next
    S1.ShowAllData
    S1.Range("A2:A" & S1.Rows.Count).Interior.Color = xlNone
    On Error GoTo 0
   
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Veri = S1.Range("A2:A" & Son).Value
   
    For X = 1 To UBound(Veri, 1)
        Dizi(Veri(X, 1)) = 1
    Next
   
    For Each Urun In Dizi.Keys
        S1.Range("A1").AutoFilter 1, Urun
        If Renk = 33 Then
            Renk = 22
        Else
            Renk = 33
        End If
        S1.Range("A2:A" & Son).SpecialCells(xlCellTypeVisible).Interior.ColorIndex = Renk
        Say = Say + 1
    Next

    On Error Resume Next
    S1.ShowAllData
    On Error GoTo 0
   
    Set S1 = Nothing
    Set Dizi = Nothing
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
   
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "Mükerrer renk sayısı ; " & Say & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
 

caytug

Altın Üye
Katılım
12 Şubat 2014
Mesajlar
47
Excel Vers. ve Dili
2003-2010
Sayın Koray çok teşekkür ederim, ellerinize sağlık
 
Katılım
25 Mayıs 2015
Mesajlar
94
Excel Vers. ve Dili
VBA
Deneyiniz.

C++:
Option Explicit

Sub Renklendir()
    Dim S1 As Worksheet, Dizi As Object, Urun As Variant
    Dim Son As Long, Veri As Variant, X As Long
    Dim Renk As Byte, Say As Long, Zaman As Double
  
    Zaman = Timer
  
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
  
    Set S1 = Sheets("Sheet1")
    Set Dizi = CreateObject("Scripting.Dictionary")
  
    On Error Resume Next
    S1.ShowAllData
    S1.Range("A2:A" & S1.Rows.Count).Interior.Color = xlNone
    On Error GoTo 0
  
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Veri = S1.Range("A2:A" & Son).Value
  
    For X = 1 To UBound(Veri, 1)
        Dizi(Veri(X, 1)) = 1
    Next
  
    For Each Urun In Dizi.Keys
        S1.Range("A1").AutoFilter 1, Urun
        If Renk = 33 Then
            Renk = 22
        Else
            Renk = 33
        End If
        S1.Range("A2:A" & Son).SpecialCells(xlCellTypeVisible).Interior.ColorIndex = Renk
        Say = Say + 1
    Next

    On Error Resume Next
    S1.ShowAllData
    On Error GoTo 0
  
    Set S1 = Nothing
    Set Dizi = Nothing
   
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
  
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "Mükerrer renk sayısı ; " & Say & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
Koray bey bende de aynı durum var. L stununda mükerrer ve belirsiz adetlerde telefon numaraları var. Bu kodu uyarladım ama çalışmadı. acaba neyi eksik yaptım
 
Katılım
17 Ekim 2009
Mesajlar
1
Excel Vers. ve Dili
2007-ENG
Alternatif;

10.000 satır ve 1.000 farklı üründe aşağıdaki kodu denedim. 20-25 saniye civarında işlem sonuçlanıyor.

Kod:
Option Explicit

Sub Renklendir()
    Dim S1 As Worksheet, Dizi As Object, Urun As Variant, Say As Long
    Dim Son As Long, Veri As Variant, X As Long, Renkler As Object, Zaman As Double
    Dim Renk_Kodu_1 As Byte, Renk_Kodu_2 As Byte, Renk_Kodu_3 As Byte
  
    Zaman = Timer
  
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
  
    Set S1 = Sheets("Sheet1")
    Set Dizi = CreateObject("Scripting.Dictionary")
    Set Renkler = CreateObject("Scripting.Dictionary")
  
    On Error Resume Next
    S1.ShowAllData
    S1.Range("A2:A" & S1.Rows.Count).Interior.Color = xlNone
    On Error GoTo 0
  
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Veri = S1.Range("A2:A" & Son).Value
  
    For X = 1 To UBound(Veri, 1)
        Dizi(Veri(X, 1)) = 1
    Next
  
    For Each Urun In Dizi.Keys
        S1.Range("A1").AutoFilter 1, Urun
Tekrar: Randomize
        Renk_Kodu_1 = Int((255 - 1 + 1) * Rnd + 1)
        Renk_Kodu_2 = Int((255 - 1 + 1) * Rnd + 1)
        Renk_Kodu_3 = Int((255 - 1 + 1) * Rnd + 1)
        If Not Renkler.Exists(RGB(Renk_Kodu_1, Renk_Kodu_2, Renk_Kodu_3)) Then
            Renkler.Add RGB(Renk_Kodu_1, Renk_Kodu_2, Renk_Kodu_3), Nothing
            S1.Range("A2:A" & Son).SpecialCells(xlCellTypeVisible).Interior.Color = RGB(Renk_Kodu_1, Renk_Kodu_2, Renk_Kodu_3)
        Else
            Say = Say + 1
            GoTo Tekrar
        End If
    Next

    On Error Resume Next
    S1.ShowAllData
    On Error GoTo 0
  
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
  
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "Mükerrer renk sayısı ; " & Say & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
bu kodu nereye giriyor ve nasıl çalıştırıyoruz?
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Dosyanızı açtıktan sonra ALT+F11 tuşlarına basarak kod editörüne ulaşabilirsiniz. Bu ekranda INSERT menüsünden MODULE ekleyerek kodları bu alana yapıştırabilirsiniz.

Sonrasında dosyanızı "Makro İçerebilen Excel Çalışma Kitabı" biçimiyle kayıt edebilirsiniz. Böylece dosyanızın uzantısı XLSM olacaktır.

Kodu ALT+F8 ile çalıştırabileceğiniz gibi sayfaya bir şekil ekleyip eklediğiniz şekil üzerinde sağ tıklayıp MAKRO ATA diyerek makroyu tanımlayabilirsiniz. Sonrasında butona tıklayarak kodu çalıştırabilirsiniz.
 
Üst