Tekrarlanan Veriyi Sayarak Listelemek

[enginenbr1]

Merhaba,

Ekteki örnek dosyada da açıklamaya çalıştığım üzere; A,B,C,D,E gibi farklı değerlerin karşısındaki adet değerlerini sayıp bunları başka bir yerde listelemek üzere bir formüle ihtiyacım var.

Yardımlarından dolayı herkese şimdiden teşekkürler.

 

[Korhan Ayhan]

Merhaba,

Tablonuza göre kullanmanız gereken özellik özet tablo seçeneğidir.

A1 hücresini seçtikten sonra EKLE-PIVOTTABLE seçeneğini seçin ve ekrana gelen komutları takip edin. Son aşamada ekranınıza gelen tablo alanına sağ tarafta çıkacak olan listeden sürükle-bırak mantığı ile istediğiniz alanları tablo üzerine yerleştirip tablonuzu oluşturun.

Formülle çözüm için ekteki örnek dosyayı inceleyin.

"H" sütununa uygulanan formül dizi formüldür. Formül hücreye uyguandıktan sonra ilgili hücre CTRL+SHIFT+ENTER tuşlarına basılarak terk edilmelidir. Aksi halde hatalı sonuçlar üretir. Mavi renkli satırları ihtiyacınız kadar alt hücrelere sürükleyin. Ayrıca formül G1 hücresindeki formüle göre şekillenmektedir. Bu sebeple G1 hücresini silmeyin.

 

[Orion1]

Makro ile yapılmış çözüm.
Dosyanız ektedir.

Option Base 1
Sub tekralananı_say()
Dim z As Object, myarr(), list(), n As Long, i As Long
Dim sat As Long
Sheets("Sheet1").Select
sat = Cells(1040000, "A").End(xlUp).Row
If sat < 2 Then
    MsgBox "A sütununda veri yok !" & vbLf & "İşlem gerçekleşmedi!", vbCritical, "U Y A R I"
    Exit Sub
End If
Application.ScreenUpdating = False
Range("H2:J1040000").ClearContents
list = Range("A2:C" & sat).Value
ReDim myarr(1 To 3, 1 To sat)
Set z = CreateObject("Scripting.Dictionary")
For i = LBound(list) To UBound(list)
    If Not z.exists(list(i, 1)) Then
        n = n + 1
        z.Add list(i, 1), n
        myarr(1, n) = list(i, 1)
        myarr(2, n) = list(i, 2)
    End If
    myarr(3, z.Item(list(i, 1))) = myarr(3, z.Item(list(i, 1))) + list(i, 3)
Next i
Erase list(): Set z = Nothing
ReDim Preserve myarr(1 To 3, 1 To n)
Range("H2").Resize(n, 3) = Application.Transpose(myarr)
Erase myarr()
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlanmıştır.", vbOKOnly + vbInformation, Application.UserName
End Sub

 

[Korhan Ayhan]

Merhaba,

Alternatif olarak gelişmiş filtre özelliğini kullanarak oluşturduğum makroyuda kullanabilirsiniz.

Option Explicit
 
Sub BENZERSİZ_LİSTELE()
    Dim İlk_Zaman As Date

    İlk_Zaman = Time

    Application.ScreenUpdating = False

    Columns("H:J").ClearContents
    Columns("A:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("H1"), Unique:=True
    Range("J1") = "Adet"
    Range("J2").Formula = "=SUMIF(A:A,H2,C:C)"
    Range("J2").AutoFill Destination:=Range("J2:J" & Cells(Rows.Count, "H").End(3).Row)
    Range("J2:J" & Cells(Rows.Count, "H").End(3).Row).Value = Range("J2:J" & Cells(Rows.Count, "H").End(3).Row).Value

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
    "İşlem süresi : " & Format(Now - İlk_Zaman, "hh:mm:ss")
End Sub

 

[enginenbr1]

Çok teşekkür ederim. Eksik olmayın.

 

[makan]

Sayın Orion1, bende resimdeki hatayı verdi.