renkli hucreleri bul birleştir ve toplamını yaz

[asterix1234]

merhaba,
g2:g200 arasında alt alta aynı renklerden olan (renkler karışık değil) hücerlerin aynı renkte olanları birleştirmek ve o renkten "G2:G200" aralığında kaç adet varrsa toplamını yazmak.

Bunun için şu kodları denedim fakat tek tek hücreleri seçtiği için merge (hücreleri birleştir)yapamıyorum. (hücre içleri bo&#351

Private Sub CommandButton2_Click()
For g = 2 To 200
If Cells(g, "g").Interior.ColorIndex = 43 Then adres = Cells(g, "g").Address & "," & adres
Next
Range(Mid(adres, 1, Len(adres) - 1)).Select
End Sub

hücrelerdeki renkler örn.
g2:g22 =27(Sar&#305
g23:g33=43(Yeşil)
g34:g56=4 (Açık Yeşil)

Renk kodlarını içeren toplam 17 rengim var.
her renk için; aynı renk hücreleri birleştirip, o renkten g2:g200 arasında kaçtane varsa toplamını birleştime (merge) yapılan hücreye yazdırmak...

 

[asterix1234]

Yardımcı olabilecek arkadaşlar yok mu ?

 

[Ferhat Pazarçevirdi]

Aşağıdaki kodu kullanınız.

Option Explicit
Sub Renkleri_Birlestir()
    
    Dim basHcr As Range
    Dim hcr As Range
    Dim rg As Range
    Dim renk As Integer
    
    Set basHcr = Range("G2")
    renk = basHcr.Interior.ColorIndex
    
    Set rg = Application.Union(basHcr, basHcr)
    
    For Each hcr In Range("G3:G36")
        If hcr.Interior.ColorIndex = renk Then
            Set rg = Application.Union(rg, hcr)
            rg.MergeCells = True
        Else
            Set rg = Application.Union(hcr, hcr)
            renk = hcr.Interior.ColorIndex
        End If
    Next
    
    Set rg = Nothing
End Sub

 

[asterix1234]

Ferhat bey,
harika olmuş bu kadar kısa zamanda (ben dün gece araştırmakla kaldım ve gece 3,5 yattım ..)

fakat aynı renklerin toplamlarını birleştirdiğim hücrelere yazdırmak istiyorum.

Ek'e örnek bir dosya koydum incelermisiniz.

bir soru daha affınıza sığınarak. işlemi hızlandırmak mümkün mü ?

 

[Ferhat Pazarçevirdi]

O zaman aşağıdakini kullanın. Hem hızlıdır hem de toplamlarını yazar

Private Sub CommandButton1_Click()
    Dim basHcr As Range
    Dim hcr As Range
    Dim rg As Range
    Dim renk As Integer
    Dim say As Integer
    Set basHcr = Range("G2")
    renk = basHcr.Interior.ColorIndex
    say = 1
    Set rg = Application.Union(basHcr, basHcr)
    Application.ScreenUpdating = False
    For Each hcr In Range("G3:G160")
        If hcr.Interior.ColorIndex = renk Then
            Set rg = Application.Union(rg, hcr)
            rg.MergeCells = True
            say = say + 1
        Else
            rg.Value = say
            Set rg = Application.Union(hcr, hcr)
            renk = hcr.Interior.ColorIndex
            say = 1
        End If
    Next
    Application.ScreenUpdating = True
    Set rg = Nothing
End Sub

 

[asterix1234]

Emeğinize sağlık. harika oldu teşekkürler.