Renkler sayılarını makro ile getirmek mümkün mü?

[achil19]

Herkese selamlar,
Makro ile yapılabilir mi bilmiyorum ama sormak istedim.
ekteki excel dosyasında "Gerçekleşen Denetimler - Kişi B" çalışma sayfasındaki renk sayılarını "ÇALIŞMLAR" sayfasına getirmek istiyorum.
Örneğin "Bingül Özen" kişisinin "Gerçekleşen Denetimler - Kişi B"sayfasında 6 yeşil, 5 mavi denetimi gözüküyor. Bu değerin "ÇALIŞMALAR" sayfasında "Bingül Özen" satırında "Yeşil renk" sütununa 6, "mavi renk" sütununa 5 yazmasını istiyorum.
Şimdiden herkese teşekkür ederim.
Makro ile olmazsa formül ile yapmak mümkünse o şekilde de olabilir.

https://drive.google.com/open?id=0B6jo34yj3V6rNUhfRzhORzBqWUU

 

[ÖmerBey]

Merhaba,
Aşağıdaki kodu deneyiniz.

Sub Kod()
Dim yesil As Integer, mavi As Integer, kirmizi As Integer
Dim a As Long, b As Long
Dim S1 As Worksheet: Set S1 = Sheets("Gerçekleşen Denetimler - Kişi B")
Dim S2 As Worksheet: Set S2 = Sheets("ÇALIŞMALAR")
mkod = 16711680
ykod = 32768
kkod = 255

For a = 2 To S2.Range("A65500").End(3).Row
    For b = 2 To S1.Range("H65500").End(3).Row
        If S1.Cells(b, "H") = S2.Cells(a, "A") Then
            If S1.Cells(b, "H").Interior.Color = mkod Then
                mavi = mavi + 1
            ElseIf S1.Cells(b, "H").Interior.Color = ykod Then
                yesil = yesil + 1
            ElseIf S1.Cells(b, "H").Interior.Color = kkod Then
                kirmizi = kirmizi + 1
            End If
        End If
    Next
    S2.Cells(a, "B") = yesil
    S2.Cells(a, "C") = mavi
    S2.Cells(a, "D") = kirmizi
    yesil = 0
    mavi = 0
    kirmizi = 0
Next
End Sub

 

[Ziynettin]

Merhaba,

Alternatif, "Scripting.Dictionary" yöntemi.

Option Explicit
Sub Renk_Say()
Dim s1 As Worksheet, s2 As Worksheet
Dim a(), b(), c(), t(), d As Object
Dim i As Long, Say As Long
Set d = CreateObject("Scripting.Dictionary")
Set s1 = Sheets("Gerçekleşen Denetimler - Kişi B")
Set s2 = Sheets("ÇALIŞMALAR")
a = s1.Range("H2:H" & s1.Range("H" & Rows.Count).End(3).Row)
b = s2.Range("A2:A" & s2.Range("A" & Rows.Count).End(3).Row)
ReDim t(1 To UBound(a), 1 To 3)
For i = 1 To UBound(a)
    If Not d.exists(a(i, 1)) Then
        Say = Say + 1
        d.Add a(i, 1), Say
    End If
    If s1.Cells(i + 1, "H").Interior.ColorIndex = 10 Then _
        t(d(a(i, 1)), 1) = t(d(a(i, 1)), 1) + 1
    If s1.Cells(i + 1, "H").Interior.ColorIndex = 5 Then _
        t(d(a(i, 1)), 2) = t(d(a(i, 1)), 2) + 1
    If s1.Cells(i + 1, "H").Interior.ColorIndex = 3 Then _
        t(d(a(i, 1)), 3) = t(d(a(i, 1)), 3) + 1
Next i
Say = 0
ReDim c(1 To UBound(b), 1 To 3)
For i = 1 To UBound(b)
    Say = Say + 1
    c(Say, 1) = t(d(b(i, 1)), 1)
    c(Say, 2) = t(d(b(i, 1)), 2)
    c(Say, 3) = t(d(b(i, 1)), 3)
Next i
s2.Range("B2:D" & Rows.Count).ClearContents
s2.[B2].Resize(Say, 3) = c
MsgBox "İşlem Tamam......", vbInformation
End Sub

http://dosya.co/plqqgfthypcw/ÇALIŞMA_EXCEL.rar.html

 

[Merhum İdris SERDAR]

.

Alternatif.

http://dosya.co/cl6nuujy694s/ÇALIŞMA_EXCEL.rar.html



.

 

[achil19]

Herkese çok teşekkür ederim, üç çalışmada çok güzel
Herkesin eline sağlık