Benzersiz kayıtların süzülmesi ve herbirinden kaçar adet değişken olduğu

[turan1971]

Başlıkta tam anlatamadım ama. Ekteki tablodan anlaşılması daha kolay olacaktır.
Kod sayfasında, kod sütunundaki tekrarlanan kodlar mevcut. Tarih haricinde diğer sütunlarda; var, yok, n/a değişkenleri var.
Benim yapmak istediğim düğmeye basıldığında tüm makronun çalışması ve tablodan tekrarlanmayacak olan kodları Özet tablosuna aktarılması ve tüm sayfada o kodların kaç tane değişkenlerden olduğu sayılması. 120 nolu kod bu sayfada 1 kere geçecek ve karşısında kaç tane var, yok, n/a değişkenlerinin olduğu sayılarak yazılacak...
mesela
KOD...VAR...YOK...N/A
120....55.....60....88
150....45.....77....93
ve devamı...
tek tek countif ile yapabildim biraz birşeyler ama sonradan boğuldum. yapamadım...
bir fikrinize ihtiyacım var... bi örnek kod olsa. ben geliştirebilirim belki...

 

[turan1971]

arkadaşlar bana bir yol gösterseniz. hangi kodu, hangi formülü kullanmalıyım mesela...

 

[turan1971]

Çözüldü

Biraz kendin pişir kendin ye gibi oldu ama. Sonunda başardım. Belki kodlar başkasına, başka bir projede lazım olur diye yazıyorum...

Dosyada ekte zaten.

Herkese kolay gelsin...

Sub çalıştır()
say = Sheets("Kod").Range("A1").CurrentRegion.Rows.Count
Sheets("Kod").Range("A1:A" & say).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets("Kod").Range("A1:A" & say), CopyToRange:=Sheets("Özet").Range("A1"), Unique:=True
say1 = Sheets("Özet").Range("A1").CurrentRegion.Rows.Count

Sheets("Özet").Range("d1").Value = "var"
Sheets("Özet").Range("e1").Value = "yok"
Sheets("Özet").Range("F1").Value = "n/a"
Sheets("Özet").Range("d1:f1").Font.Bold = True

For i = 2 To say1

Sheets("Özet").Range("b" & i).Value = Application.SumIf(Sheets("Kod").Range("A1:A" & say), Sheets("Özet").Range("a" & i), Sheets("Kod").Range("b1:b" & say))
Sheets("Özet").Range("c" & i).Value = Application.CountIf(Sheets("Kod").Range("A1:A" & say), Sheets("Özet").Range("a" & i))

Sheets("Kod").Range("A1:H" & say).AutoFilter Field:=1, Criteria1:=Sheets("Özet").Range("A" & i)
say2 = Sheets("Özet").Range("c" & i).Value

Sheets("Özet").Range("d" & i).Value = Application.CountIf(Sheets("Kod").Range("C1:H" & say2), Sheets("Özet").Range("d1"))
Sheets("Özet").Range("e" & i).Value = Application.CountIf(Sheets("Kod").Range("C1:H" & say2), Sheets("Özet").Range("e1"))
Sheets("Özet").Range("f" & i).Value = Application.CountIf(Sheets("Kod").Range("C1:H" & say2), Sheets("Özet").Range("f1"))


Next
Selection.AutoFilter
End Sub

 

[Recep İpek]

Alternatif olarak aşağıdaki kodlarıda deneyebilirsiniz.

Bu arada benim bulduğum sonuçlar ile sizinki farklı çıkıyor.Bilginize.

Sub AktarTopla()
Dim a, b, i, n, sat, veri()
Set s1 = Sheets("Kod")
Set s2 = Sheets("Özet")
'*******************************************
a = s1.Range("a2:h" & s1.[a65536].End(3).Row).Value
ReDim veri(1 To UBound(a, 1), 1 To 6)
'*******************************************
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For i = 1 To UBound(a, 1)
        z = a(i, 1)
           If Not IsEmpty(z) Then
                 If Not .exists(z) Then
                    n = n + 1
                    .Add z, n
                    veri(n, 1) = a(i, 1)
                End If
                    veri(.Item(z), 2) = veri(.Item(z), 2) + a(i, 2)
                    veri(.Item(z), 3) = veri(.Item(z), 3) + 1
                   For j = 3 To 8
                        If a(i, j) = "var" Then
                            veri(.Item(z), 4) = veri(.Item(z), 4) + 1
                        ElseIf a(i, j) = "yok" Then
                            veri(.Item(z), 5) = veri(.Item(z), 5) + 1
                        ElseIf a(i, j) = "n/a" Then
                            veri(.Item(z), 6) = veri(.Item(z), 6) + 1
                        Else
                            veri(.Item(z), 4) = 0
                            veri(.Item(z), 5) = 0
                            veri(.Item(z), 6) = 0
                        End If
                    Next j
           End If
    Next i
End With
'*******************************************
sat = s2.[a65536].End(3).Row + 1
s2.Range(s2.Cells(2, "a"), s2.Cells(sat, "f")).ClearContents
s2.[a2].Resize(n, 6).Value = veri
''*******************************************
s2.Select
MsgBox "Raporlama Tamamlandı", vbInformation, "Bilgi"
Set s1 = Nothing
Set s2 = Nothing
End Sub