Koşullu Biçimlendirme-Fiş Numarası Değiştikçe

[altan888]

Merhabalar
Excel tablomda alt alta numaralı olarak muhasebe fiş dökümleri bulunmaktadır ve bir muhasebe fişi 1 den fazla satırdan oluşmaktadır, ve fiş noları ardışık değildir, bir muhasebe fişim kaç satırdan oluşuyor ise B sütununda aynı muhasebe fişi için aynı muhasebe numaralandrımasını yaptım ancak benim sizden ricam örneğin; 9 satırdan oluşan 2027 nolu fişten sonra 8 satırdan oluşan 2469 nolu fiş geliyor ise bu 2469 nolu muhasebe fişinin tüm satırları ayrı renklensin, yani bir muhasebe fişi renkli olacak bir muhasebe fişi renksiz olacak ve böyle alt alta devam edip gidecek, benim gözle takip ve kontrol açısından çok işime yarayacak, yardımcı olmanızı rica ederim, şimdiden teşekkürler, iyi çalışmalar. (makrosuz bir çözüm olursa çok sevinirim)

 

[antonio]

Merhaba,
Aşağıdaki kodları deneyiniz.

Sub ayni_olanlari_renklendir()
Dim sh As Worksheet, ss As Long, i As Long, renk(), z As Object, r As Byte
r = 0
n = 0
renk = Array(48, 44, 42, 40, 39, 38, 36, 33, 28, 26, 24, 22, 20, 17, 15, 8, 7, 6, 4, 3)
Set sh = Sheets(Sheets(1).Name)
ss = sh.Range("B" & Rows.Count).End(3).Row
Set z = CreateObject("scripting.dictionary")
    For i = 2 To ss
        If sh.Range("B" & i).Value <> "" Then
            aranan = sh.Range("B" & i).Value
            If Not z.exists(aranan) Then
                r = r + 1
                n = n + 1
                z.Add aranan, r
                z(aranan) = r
                n = r
                sh.Range("A" & i & ":C" & i).Interior.ColorIndex = renk(r)
            Else
                sh.Range("A" & i & ":C" & i).Interior.ColorIndex = renk(z(aranan))
            End If
        End If
    Next i
    MsgBox "İşlem tamamlnadı", vbInformation, "antonio"
End Sub

 

[altan888]

Merhaba,
Aşağıdaki kodları deneyiniz.

Sub ayni_olanlari_renklendir()
Dim sh As Worksheet, ss As Long, i As Long, renk(), z As Object, r As Byte
r = 0
n = 0
renk = Array(48, 44, 42, 40, 39, 38, 36, 33, 28, 26, 24, 22, 20, 17, 15, 8, 7, 6, 4, 3)
Set sh = Sheets(Sheets(1).Name)
ss = sh.Range("B" & Rows.Count).End(3).Row
Set z = CreateObject("scripting.dictionary")
    For i = 2 To ss
        If sh.Range("B" & i).Value <> "" Then
            aranan = sh.Range("B" & i).Value
            If Not z.exists(aranan) Then
                r = r + 1
                n = n + 1
                z.Add aranan, r
                z(aranan) = r
                n = r
                sh.Range("A" & i & ":C" & i).Interior.ColorIndex = renk(r)
            Else
                sh.Range("A" & i & ":C" & i).Interior.ColorIndex = renk(z(aranan))
            End If
        End If
    Next i
    MsgBox "İşlem tamamlnadı", vbInformation, "antonio"
End Sub

Sayın antonio
Cevap için çok teşekkür ederim ancak makrosuz bir çözümü var mıdır ?

 

[antonio]

Sayın antonio
...makrosuz bir çözümü var mıdır ?

Koşullu biçimlendirmeye fiş numaralarını tanıtabilirsiniz. Bu şekilde her fiş numarası için ayrı bir dolgu biçimlendirmesi yapmayı deneyiniz.

 

[altan888]

Makrosuz çözüm

Merhabalar, kendimce makrosuz bir çözüm buldum, yardımcı sütun ve koşullu biçimlendirme ile, ihtiyacı olan olabilir diye excel dosyamı ekte paylaşıyorum