Peşpeşe kaç adet renkli yazı var?

[Bora K]

İyi akşamlar

Sütunda peşpeşe kaç tane renkli yazı var
bunu tespit etmek için makro koduna ihtiyacım
konuya hakim değerli uzmanların yardımlarını
bekliyorum.

 

[Necdet]

Merhaba,

Aşağıdaki kodları bir modüle kopyalayıp dener misiniz?

Sub Say()
    
    Dim i       As Integer
    Dim a(1)    As Integer
    Dim b(1)    As Integer
    
    
    For i = 5 To 29
    
        If Range("B" & i).Font.ColorIndex < 0 Then
            If b(0) > a(0) Then a(0) = b(0)
            b(0) = 0
        Else
            b(0) = b(0) + 1
        End If
        
        If Range("C" & i).Font.ColorIndex < 0 Then
            If b(1) > a(0) Then a(1) = b(1)
            b(1) = 0
        Else
            b(1) = b(1) + 1
        End If
            
    Next i
    
    Range("B30") = a(0)
    Range("C30") = a(1)
    
    MsgBox "İşlem Tamamlanmıştır...", vbInformation, "Excel.Web.Tr"
    
End Sub

 

[Bora K]

Merhabalar
Necdet Hocam.

Elinize zihninize sağlık.
Kod tamda istediğim gibi olumuş kusursuz işlemekte.

Teşekkür ederim.
Saygılarımla.

 

[Bora K]

Tekrardan merhabalar

Değerli arkadaşlar.
Mevcut kod B ve C sütununda çalışıyor
D sütununu da ilave etmek istedim lakin başaramadım.
Yardımcı olabilirmisiniz acaba?

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu deneyin. Kırmızı renkli 4 ("D") değeri son sütunu ifade etmektedir. Siz ihtiyacınıza göre değiştirirsiniz.

Sub Say()
    Dim X As Integer
    Dim Y As Integer
    Dim Sutun As Integer
    Dim Renk_Say As Integer
    
    Sutun = [COLOR="red"]4[/COLOR]
    
    Range("B30:" & Cells(30, Sutun).Address(0, 0)) = ""
    
    For X = 2 To Sutun
        For Y = 5 To 28
            If Cells(Y, X).Font.ColorIndex = 10 And Cells(30, X) < 1 Then Cells(30, X) = 1
            If Cells(Y, X).Font.ColorIndex = 10 And Cells(Y + 1, X).Font.ColorIndex = 10 Then
                Renk_Say = Renk_Say + 1
            Else
                If Renk_Say > Cells(30, X) Then
                    Cells(30, X) = Renk_Say
                End If
                Renk_Say = 0
            End If
        Next
    Next
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Necdet]

Merhaba,

Sub Say()
 
    Dim i       As Integer
    Dim a([B]2[/B])    As Integer
    Dim b([B]2[/B])    As Integer
 
 
    For i = 5 To 29
 
        If Range("B" & i).Font.ColorIndex < 0 Then
            If b(0) > a(0) Then a(0) = b(0)
            b(0) = 0
        Else
            b(0) = b(0) + 1
        End If
 
        If Range("C" & i).Font.ColorIndex < 0 Then
            If b(1) > a(0) Then a(1) = b(1)
            b(1) = 0
        Else
            b(1) = b(1) + 1
        End If
 
[B]       If Range("D" & i).Font.ColorIndex < 0 Then[/B]
[B]           If b(2) > a(0) Then a(2) = b(2)[/B]
[B]           b(2) = 0[/B]
[B]       Else[/B]
[B]           b(2) = b(2) + 1[/B]
[B]       End If[/B]
            
    Next i
 
    Range("B30") = a(0)
    Range("C30") = a(1)
   [B] Range("D30") = a(2)[/B]
 
    MsgBox "İşlem Tamamlanmıştır...", vbInformation, "Excel.Web.Tr"
 
End Sub

 

[monelogg]

Merhaba, Necdet Bey'in yazdığı kodla ilgili bir soru aklıma takıldı, onu sormak istiyordum, ben de dün kodda aynı değişiklikleri yaptım ama denemelerim sonucunda şöyle bir durum oluştu:
D hücresinden 1-2 hücrenin yazısının rengini değiştirdiğimde değer olarak sıfır gösteriyor ama 10-15 hücre seçince doğru sonucu gösteriyor. Ama aynı değişikliği B veya C sütununda uyguladığımda doğru sonuç aldım. Necdet Bey'in kodlarıyla da denedim aynı sonucu verdi. Neden böyle olduğunu öğrenmem mümkün müdür?