Benzersiz olanı başka sayfada listeleme ve toplam alma

[serkans]

Merhaba

Ekteki dosyada sayfa 1 de a sütununa veri girilince sayfa 2 a sütununa mükerrerleri ve tek olanları birer tane yazıp, b sütununa aynsısından kaç tane olduğu ce c sütununda yanına toplam alsın.

Forumda araştırdım dünden bugüne çeşitli denemeler yaptım ama tutturamadım. Çoğu mesajda da örnek dosyalar sanırım silinmiş olduğu için açamadım.

Yardımcı olursanız sevinirim, formüllerimde sorun yok ama inş.bu kodları da öğreneceğim yardımlarınızla...

Şimdiden teşekkürler.

 

[serkans]

yardım edebilir misiniz?

 

[halit3]

Kod

Sub deneme()
Worksheets("Sayfa2").Columns("A:C").ClearContents
sat = 1
For r = 2 To Worksheets("Sayfa1").Cells(Rows.Count, "A").End(3).Row
aranan1 = Sheets("Sayfa1").Cells(r, "A").Value
say1 = 0
say2 = 0
If Sheets("Sayfa1").Cells(r, "A").Value <> "" Then
If WorksheetFunction.CountIf(Worksheets("Sayfa1").Range("A1:A" & r), aranan1) = 1 Then
For i = r To Worksheets("Sayfa1").Cells(Rows.Count, "A").End(3).Row
aranan2 = Sheets("Sayfa1").Cells(i, "A").Value
If aranan2 = aranan1 Then
say1 = say1 + CDbl(Sheets("Sayfa1").Cells(i, "B").Value)
say2 = say2 + 1
End If
Next i
Sheets("Sayfa2").Cells(sat, 1).Value = Sheets("Sayfa1").Cells(r, 1).Value
Sheets("Sayfa2").Cells(sat, 2).Value = say2
Sheets("Sayfa2").Cells(sat, 3).Value = say1
sat = sat + 1
End If
End If
Next r
MsgBox "işlem tamam"
End Sub

 

[serkans]

halit hocam

çok teşekkür ederim...

 

[halit3]

halit hocam

çok teşekkür ederim...

İyi çalışmalar

 

[assenucler]

Teşekkürler halit3 üstadım.

İstanbul'dan selam ve sevgiler.

 

[serkans]

hocam tekrar merhaba

örnek dosyada a sütunu b ye kaydırarak sütun ekledim. kodunuzdaki "a" sütunlarını da b olarak düzelttim. Ama şehir adları gelmedi.

yardımcı olabilir misiniz?