Listeden Özet Rapor alma

[kemalist]

Arkadaşlar bir listem var ve buradan diğer sayfaya bilgiler alarak özet rapor oluşturmak.Geniş açıklama örne

 

[uur1435]

İstediğiniz bu şekilde mi?

 

[kemalist]

Hayır açıklamayı okumadınız herhalde...

 

[Ziynettin]

Sub test()
Dim s1 As Worksheet, s2 As Worksheet
Dim a(), b(), d As Object, say As Long, y As Byte, sat As Long
Dim i As Long, kosul As String, krt As String
Set s1 = Sheets("FASON")
Set s2 = Sheets("RAPOR")
Set d = CreateObject("scripting.dictionary")
kosul = "FASON"
s2.Range("A3:J" & Rows.Count).Clear
a = s1.Range("B3:M" & s1.Cells(Rows.Count, 2).End(3).Row).Value
ReDim b(1 To UBound(a), 1 To 10)
    For i = 1 To UBound(a)
        If kosul = a(i, 1) Then
            krt = a(i, 2)
            If Not d.exists(krt) Then
                d(krt) = d.Count + 1
                say = d.Count
                b(say, 1) = krt
            End If
            sat = d(krt)
            For y = 2 To 9
            b(sat, y) = b(sat, y) + a(i, y + 3)
            b(sat, 10) = b(sat, 10) + a(i, y + 3)
            Next y
        End If
    Next i
If say > 0 Then
    For i = 1 To say
        For y = 2 To 10
            b(say + 1, y) = b(say + 1, y) + b(i, y)
        Next y
    Next i
    s2.[A3].Resize(say + 1, 10) = b
    s2.[A3].Offset(say) = "TOPLAM"
    s2.[A3].Resize(say + 1, 10).Borders.Color = 1
    s2.[A3].Offset(say).Resize(, 10).BorderAround , xlMedium
End If
MsgBox "İşlem bitti..", vbInformation
End Sub

 

[kemalist]

Sayın Ziynettin ilginiz için çok teşekkür ederim.Tek bir sorum olacak satır sayısı 1050 ye kadardı makroyu ona göremi düzenlediniz?

 

[Ziynettin]

Fason sayfası B sütununda dolu son satıra göre.

 

[kemalist]

Pekala yeni veriler girdiğimizde umarım sorun olmaz