Veri değiştiğinde renk değişsin.

[Carpintero]

Merhaba arkadaşlar aşağıdaki işlemi yapan bir makro vardı
lakin aradım bulamadım. Acaba elinde olan paylaşabilir mi.
Verinin türü değiştikçe renk de değişiyor.
rengin tekrar etmesi vs önemli değil iki veri birbirinden ayrılsın yeterli.

https://i.hizliresim.com/nQ0MNM.jpg

 

[mab82981]

hocam alt satırdaki veri değişince mi renk değişsin yoksa Bütün "A" harfleri için aynı renk mi olsun mesela ?

 

[Carpintero]

hocam alt satırdaki veri değişince mi renk değişsin yoksa Bütün "A" harfleri için aynı renk mi olsun mesela ?

Merhaba
2. satıra bir renk atayacağız.
2. satırdaki veri A olsun
A devam ettiği sürece aynı renk devam edecek.
A dan sonraki veriye yeni bir renk atayacağız
böyle böyle son satıra kadar gideceğiz

 

[çıtır]

Sayfa kodu olarak kopyalayınız.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [H2:H10000]) Is Nothing Then Exit Sub
Dim YeniSayı As Integer
son = Target.Row
say = WorksheetFunction.CountIf(Range("H2:H" & son), Range("H" & son))
If say = 1 Then
YeniSayı = Int((56 * Rnd) + 1)
Range(Cells(son, 6), Cells(son, 9)).Interior.ColorIndex = YeniSayı
Else
bak = WorksheetFunction.Match(Range("H" & son), Range("H2:H" & son), 0)
Range(Cells(son, 6), Cells(son, 9)).Interior.Color = Range("H" & bak + 1).Interior.Color
End If
End Sub

 

[mab82981]

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim renk As Long
    Dim renky As Long
    renk = 3
    Range("F2:I2").Interior.ColorIndex = renk
    son = Cells(Rows.Count, 6).End(xlUp).Row
        For syc = 3 To son
            If Cells(syc, 6).Value = Cells(syc - 1, 6) Then
                Range("F" & syc & ":I" & syc).Interior.ColorIndex = renk
            Else
t1:
                Randomize
                renky = WorksheetFunction.RandBetween(3, 20)
                If renky <> renk Then
                    renk = renky
                    Range("F" & syc & ":I" & syc).Interior.ColorIndex = renk
                Else
                GoTo t1
                End If
            End If
        Next syc
End Sub

Bende bunu yazdım hocam. Hangisi işinizi görürse

 

[Carpintero]

Merhaba sayın Çıtır ve mab82981
alakanız için çok teşekkür ederim.

Makroyu buton yardımı ile çalıştırabilir miyiz acaba
Başka kodların içinde kullanacağım çünkü.
Makronun tek sefer çalışması yeterli.

Renk hususunda ise kendimiz belirler isek çok şahane olur.

 

[mab82981]

Benim yazdığım kodu buton ile çalıştırabilirsiniz. Tek renk değil hocam nasıl belirleyeceksiniz biraz açar mısınız?

 

[Carpintero]

Benim yazdığım kodu buton ile çalıştırabilirsiniz. Tek renk değil hocam nasıl belirleyeceksiniz biraz açar mısınız?

Evet buton ile çalışıyor makro
Ama sadece bir tane hücre boyuyor.
Örnek resimdeki gibi aynı tür olanların tamamını boyaması lazım.
Olaya A olarak bakmayacağız. 2 ten başladı döngü
2 ile 3 ü karşılaştıracak aynı ise boyayacak sonra 3 ile 4 ü karşalaştıracak
böyle böyle aynı olduğu sürece boyanmaya devam edecek.
Farklı veri geldiğinde renk de değşiecek.

 

[mab82981]

https://www.dosyaupload.com/69vx
hocam bu linkteki dosyayı indirip bakabilirsiniz. Butona bağladım. Butona tıklayınca dediğiniz işlemi yapıyor. Eğer her veri değiştiğinde bu işlemi yapsın diyorsanız o zaman butona bağlanmaz veri değişince tekrar burona tıklayıp düzeltmeniz lazım.

 

[mab82981]

https://i.hizliresim.com/Wq3YmP.png örnek resim

 

[ÖmerBey]

Merhaba,
Alternatif olsun:

Sub Kod()
For a = 2 To Cells(Rows.Count, "H").End(3).Row
    If Cells(a, "H").Value <> Cells(a - 1, "H").Value Then
        renk = renk + 1
    End If
    Range("F" & a & ":I" & a).Interior.ColorIndex = (renk Mod 55) + 2
Next
End Sub

 

[Carpintero]

Hepinize ayrı ayrı teşekkür ederim
Değerli insanlar.

Daha silik bir renk kataloğu koyabilir miyiz acaba?
Renkler içeriklerin okunmasını engelliyor.

 

[ÖmerBey]

Kullanmak istediğiniz renklerin vba kodlarını belirtirseniz ona göre düzenlenir.
Seçtiğiniz bir hücrenin arkaplan renk kodunu şu kodla öğrenebilirsiniz.

Sub RenkKodu()
MsgBox Selection.Interior.Color
End Sub

 

[Carpintero]

Ömer Bey çok teşekkür ederim alakanız için.
12379351 15986395 11851260 14336204
şu kodlar sırası ile kullanılsa yeterli olur.
Amaç gurupları birbirinden ayırmak.
Şayet ihtiyaç duyulur ise örneğe bakarak kendim revize de
edebilirim diye umuyorum.

 

[ÖmerBey]

Kodunuzun düzenlemiş hali aşağıdadır.
İhtiyaç duyduğunuz renk kodlarını diziye ekleyerek kullanabilirisniz.

Sub Kod()
renkler = Array(14336204, 12379351, 15986395, 11851260)
For a = 2 To Cells(Rows.Count, "H").End(3).Row
    If Cells(a, "H").Value <> Cells(a - 1, "H").Value Then
        renk = renk + 1
    End If
    Range("F" & a & ":I" & a).Interior.Color = renkler(renk Mod (UBound(renkler) + 1))
Next
End Sub

 

[Carpintero]

Tekrar teşekkür ederim.
Cümleten esen kalın.