Sütundaki değerleri sayma Hk.

[ByChilavert]

Merhaba Arkadaşlar

A Sütununda aşağı doğru görevler var bu görevleri yan tarafta =EĞERSAY($A$1:$A$1500;"AHŞAP KALIP USTASI") olarak saydırıyorum ama bir çok görev olduğu için tek tek bu işlemi yapmak zaman alıyor bunu kısa yoldan makro yada kod ile yapabilir miyim.

... Link ...

 

[askm]

Sub askm()
Dim son As Long
son = Range("A" & Rows.Count).End(3).Row

Application.ScreenUpdating = False
With Sheets("sayfa1")
    .Range("A1:a" & son).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    .Range("A2:a" & son).Copy Sheets("sayfa1").Range("b2")
    .ShowAllData
    
    For i = 2 To Range("B" & Rows.Count).End(3).Row
        Cells(i, 3) = WorksheetFunction.CountIf(Range("A1:A" & son), Cells(i, 2))
    Next i
End With
Application.ScreenUpdating = True
End Sub

 

[Orion1]

Dosyanız linktedir.

DOSYAYI INDIR

Sub say59e()
Dim liste(), i As Long, z As Object
Range("B2:C" & Rows.Count).ClearContents
liste = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row).Value
Set z = CreateObject("scripting.dictionary")
For i = 1 To UBound(liste)
    If Not z.exists(liste(i, 1)) Then
        z.Add liste(i, 1), 1
    Else
        z.Item(liste(i, 1)) = z.Item(liste(i, 1)) + 1
    End If
Next i
Erase liste()
If z.Count > 0 Then
    Range("B2").Resize(z.Count, 2) = Application.Transpose(Array(z.keys, z.items))
    MsgBox "bitti"
End If
Set z = Nothing
End Sub

 

[ByChilavert]

Çok Teşekkür Ederim.