Düşey Ara Formülü

[mafia24]

Selamlar, Eklemiş olduğum örnek excel dosyasında model bazlı stok bilgileri yer almaktadır. Her model listesi arasında boşluklar bulunmaktadır. bir stok kodu A modelinde, B modelinde ve C modelinde de bulunmaktadır. Benim yapmak istediğim stok kodunu düşey ara ile sayfada aratmak ürün bilgisini getirmek ve hangi modellerde var olduğunu satır satır yazdırmak. Eklemiş olduğum excel dosyasının ikinci sayfasında manuel yaptığım liste bulunmaktadır dosyadan daha net anlaşılmaktadır. Konu hakkında yardımlarınızı rica ederim.

 

[veyselemre]

Sub test()

    Sheets("Sayfa1").Select
    Dim w()
    With CreateObject("scripting.dictionary")
        For i = 1 To Cells(Rows.Count, "A").End(3).Row
            If Cells(i, "C").Value = "" Then
                Model = Trim(Cells(i, "B").Value)
            Else
                If Cells(i, "A").Value <> "" Then
                    stkKod = Cells(i, "A").Value
                    stkAd = Trim(Cells(i, "F").Value)
                    yillar = Split(Trim(Cells(i, "D").Value), "&#8211;")
                    For s = 0 To UBound(yillar)
                        If yillar(s) > 50 Then frm = "1900" Else frm = "2000"
                        yillar(s) = Format(yillar(s), frm)
                    Next s
                    yil = Join(yillar, "-")
                    If Right(yil, 1) = "-" Then yil = yil & Year(Date)
                    ss = 1
                    If .exists(stkKod) Then
                        w = .Item(stkKod)
                        ss = UBound(w, 2) + 1
                    End If
                   
                    ReDim Preserve w(1 To 4, 1 To ss)
                    w(1, ss) = stkKod
                    w(2, ss) = stkAd
                    w(3, ss) = Model
                    w(4, ss) = yil
                    .Item(stkKod) = w
                
                End If
            End If
        Next i
        itms = .items
    End With
    Sheets("Sayfa2").Select
    Range("a2:D" & Rows.Count).ClearContents

    For Each elem In itms
        Cells(Rows.Count, 1).End(3).Offset(1, 0).Resize(UBound(elem, 2), 4).Value = Application.Transpose(elem)
    Next elem

End Sub

 

[mafia24]

Çok teşekkür ederim verdiğiniz kodlar işime yaradı.