Çözüldü Koşullu Biçimlendirme/Say

[gicimi]

Merhaba;

A Sütunundaki Aynı Sayıları Yeşile boyamak
B Sütunundaki Aynı Sayıları Maviye boyamak

C Sütununa A Sütunundaki Yeşil boyalı satırları saydırma
D Sütununa B Sütunundaki Mavi boyalı satırları saydırma.

Kod nasıl yazılmalı yardımcı olabilir misiniz. Teşekkürler.

 

[turist]

Deneyin.

Sub gicimi()
Columns("A:D").Select
   With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
For i = 1 To Cells(Rows.Count, 1).End(3).Row
If Application.WorksheetFunction.CountIf(Range("A:A"), Cells(i, 1)) > 1 Then
Cells(i, 1).Interior.ColorIndex = 4
End If
Next
For i = 1 To Cells(Rows.Count, 2).End(3).Row
If Application.WorksheetFunction.CountIf(Range("B:B"), Cells(i, 2)) > 1 Then
Cells(i, 2).Interior.ColorIndex = 8
End If
Next
For i = 1 To Cells(Rows.Count, 1).End(3).Row
If Application.WorksheetFunction.CountIf(Range("A:A"), Cells(i, 1)) > 1 Then
Cells(i, 3).Value = Application.WorksheetFunction.CountIf(Range("A:A"), Cells(i, 1))
End If
Next
For i = 1 To Cells(Rows.Count, 2).End(3).Row
If Application.WorksheetFunction.CountIf(Range("A:A"), Cells(i, 2)) > 1 Then
Cells(i, 4).Value = Application.WorksheetFunction.CountIf(Range("B:B"), Cells(i, 2))
End If
Next
End Sub

 

[Ömer BARAN]

Merhaba.

Sayın turist'in müsadesiyle ve kendisiyle aynı yöntemi kullanarak tek döngü ile çözüm alternatif olsun.

Sub gicimi_BRN()
Set wf = Application.WorksheetFunction
sonsat = wf.Max(Cells(Rows.Count, 1).End(3).Row, Cells(Rows.Count, 2).End(3).Row)
Range("A1:B" & sonsat).Interior.Color = xlNone
Range("C1:D" & sonsat).ClearContents
For brn = 1 To sonsat
    If Cells(brn, 1) <> "" And wf.CountIf(Range("A1:A" & sonsat), Cells(brn, 1)) > 1 Then
        Cells(brn, 1).Interior.ColorIndex = 4
        Cells(brn, 3) = wf.CountIf(Range("A1:A" & sonsat), Cells(brn, 1))
    End If
    If Cells(brn, 2) <> "" And wf.CountIf(Range("B1:B" & sonsat), Cells(brn, 2)) > 1 Then
        Cells(brn, 2).Interior.ColorIndex = 8
        Cells(brn, 4) = wf.CountIf(Range("B1:B" & sonsat), Cells(brn, 2))
    End If
Next
End Sub

 

[gicimi]

Sn. @turist @Ömer BARAN teşekkür ederim. Kolaylıklar.