Otamatik tablo yapımı

[marmara1453]

Merhabalar ,

alttaki adreste belirtmiş olduğum excel dosyanın sheet1 deki verileri otamatik olarak sheet 2 de bulunan tabloya şartlı olarak aldırmak istiyorum.Yapılabilir mi ? Yardımlarınız için şimdiden teşekkür ederim.

Not : Almak istediğim sonuç Örnek olarak sheet3 de gösterilmiştir.


https://www.dosyaupload.com/54hw

 

[Emir Hüseyin Çoban]

.

Sheet1 sayfasındaki liste ortalama kaç satır olabilir.

.

 

[marmara1453]

en fazla 100 olarak dikkate alabiliriz

 

[Emir Hüseyin Çoban]

.

Sub KOD()
    
    Dim SD As Worksheet: Set SD = Sheets("Sheet1")
    Dim SO As Worksheet: Set SO = Sheets("Sheet2")

    Dim dic As Object, liste(), dizi()

    son = SD.Cells(Rows.Count, "C").End(3).Row
    liste = SD.Range("C5:G" & son).Value

    ReDim dizi(1 To son, 1 To 5)

    Set dic = CreateObject("scripting.dictionary")

    For x = 1 To UBound(liste, 1)
        aranan = liste(x, 5)

        If Not dic.exists(aranan) Then
            n = n + 1
            dic.Add aranan, n
            ReDim Preserve dizi(1 To son, 1 To 5)
            dizi(n, 1) = liste(x, 5)
            dizi(n, 2) = liste(x, 4)
        End If
        dizi(dic.Item(aranan), 3) = dizi(dic.Item(aranan), 3) & liste(x, 1) & "-"
    Next x

    SO.Range("a2:c" & Rows.Count).ClearContents
    SO.Range("A2").Resize(dic.Count, 3) = dizi

End Sub

.