Araç İcmali Oluşturma

[quixotic79]

Merhaba arkadaşlar yapmak istediğim şey şudur; bu listedeki verilere göre alt tarafta bulunan "İcmal" sekmesinin içine bir icmal listesi oluşturacak. Araç listesi "F" sütunundaki tanıma göre ise icmaldeki araç grubu "B" sütunu düzenlensin aynısı varsa değerleri öncekinin üzerine aynı tanım yok ise yeni bir satır olarak eklemeli. "B" sütununda aynı kodla ayrılmış olan araçlar "İcmal" sekmesinde "C" sütununu yani araç sayısını belirtirken, araç listesi "E" sütunu yani tipi sütunundaki verilerin çeşitliliğine göre icmaldeki "D" sütunu yani araç çeşitliliği düzenlensin.(İçi aynı olan hücreleri birleştirip sayacak ayrı olanları ayrı ayrı) Aynı kodlu araçların model yaşlarını ise ortalama alarak icmaldeki "E" sütununa yani ortalama model yılı sütununa eklesin, bunu yapacak bir makro kodu veya formül yazan arkadaşa şimdiden hürmet ve teşekkür ederim. İyiki varsınız.

Örnek dosya ektedir.
http://s8.dosya.tc/server2/gye5wg/arac_listesi_excel_web.xls.html

 

[veyselemre]

Sub TEST()
    With CreateObject("Scripting.Dictionary")
        lst = Sheets("araç listesi").Range("B3:G" & Sheets("araç listesi").Cells(Rows.Count, 2).End(3).Row).Value
        Sheets("İcmal").Range("A3:F49").ClearContents
        ReDim w(1 To UBound(lst), 1 To 6)
        For i = LBound(lst) To UBound(lst)
            Key = lst(i, 1) & "|" & lst(i, 4)
            If Not .exists(Key) Then
                idx = .Count + 1
                w(idx, 1) = lst(i, 1)
                w(idx, 2) = lst(i, 5)
                w(idx, 3) = 1
                w(idx, 4) = 1
                w(idx, 5) = lst(i, 6)
                .Add Key, idx
            Else
                idx = .Item(Key)
                w(idx, 3) = w(idx, 3) + 1
                w(idx, 5) = w(idx, 5) + lst(i, 6)
            End If
        Next i
        son = .Count
        .RemoveAll
        For i = LBound(w) To son - 1
            For ii = i + 1 To son
                If w(ii, 1) <> "" And w(i, 1) = w(ii, 1) Then
                    w(ii, 1) = ""
                    w(i, 3) = w(i, 3) + w(ii, 3)
                    w(i, 4) = w(i, 4) + 1
                    w(i, 5) = w(i, 5) + w(ii, 5)
                End If
            Next ii
        Next i
        sat = 3
        For i = LBound(w) To son
            If w(i, 1) <> "" Then
                w(i, 5) = Int(w(i, 5) / w(i, 3))
                w(i, 6) = Year(Date) - w(i, 5)
                Sheets("İcmal").Cells(sat, 1).Resize(, 6).Value = Application.Index(w, i)
                sat = sat + 1
            End If
        Next i
    End With
    Erase w, lst
End Sub

 

[quixotic79]

kardeşim Allah razı olsun tam istediğim şey son bir ricam, aynı kodu araç listesi sekmesi kod sütunu "I" olacak şekilde de yazabilirmisin ben düzenleyemedim anlayamadım daha doğrusu Kod hanesi araç listesi sekmesi "I" sütununda olsaydı nasıl yazılırdı... çok teşekkür ederim...