Listedeki verileri baska sayfada karsilastirma ve sonuclari tasima

[fredycrouger]

Selamlar,

Bu gune kadar cok desteginizi gordum, oncelikle tekrar her biri icin tesekkur ederim.

Eklemis oldugum dosyada "Chains" ve "ChainMapping" sayfalari var. Yapmaya calistigim makro asagidaki sekilde calismali:

Chains sayfasinda sutun D altindaki veriyi ChainMapping sayfasinda sutun A da arayip, eger eslesirse B sutunundan son veri olan sutuna kadar kopyalamak ve Chains sayfasinda sutun D altina sonuclari dikey olarak yapistirmak (satir ekleyerek, ayrica arattigimiz veri silinecek ve sadece sonuclar olacak). D sutunu altindaki ikinci ve sonraki degerler icin ayni islem devam edecek (son veri olan hucreye kadar).

Ornek dosya: https://file.io/CR9kjfpYdAok

Simdiden cok tesekkurler.
Saygilar,
Ferdi

 

[ÖmerFaruk]

Dosyanız silinmiş

 

[fredycrouger]

Merhaba Omer bey,

Neden silindi hic bir fikrim yok, bilgi icin tesekkurler.

Yeni link:

https://easyupload.io/v4qbxz

Umarim bu kez silinmez

 

[veyselemre]

Sub test()
    Dim dic As Object, i&, ii&
    Dim sh As Worksheet, say&, lst, al
    Set dic = CreateObject("Scripting.Dictionary")
    Set sh = Sheets("ChainMapping")
    For i = 2 To sh.Cells(Rows.Count, 1).End(3).Row
        say = sh.Cells(i, 1).End(2).Column
        ReDim w(1 To 1, 1 To say - 1)
        For ii = 2 To say
            w(1, ii - 1) = sh.Cells(i, ii).Value
        Next ii
        dic.Add sh.Cells(i, 1).Value, w
    Next i
    Set sh = Sheets("Chains")

    say = sh.Cells(Rows.Count, 4).End(3).Row

    If say < 2 Then Exit Sub
    lst = sh.Range("D2:D" & say).Value
    sh.Range("D2:D" & say).ClearContents

    For i = 1 To UBound(lst)
        If dic.exists(lst(i, 1)) Then
            al = Application.Transpose(dic(lst(i, 1)))
            say = UBound(al)
            sh.Cells(Rows.Count, 4).End(3).Offset(1).Resize(say).Value = al
        End If
    Next i
End Sub

 

[fredycrouger]

Sub test()
    Dim dic As Object, i&, ii&
    Dim sh As Worksheet, say&, lst, al
    Set dic = CreateObject("Scripting.Dictionary")
    Set sh = Sheets("ChainMapping")
    For i = 2 To sh.Cells(Rows.Count, 1).End(3).Row
        say = sh.Cells(i, 1).End(2).Column
        ReDim w(1 To 1, 1 To say - 1)
        For ii = 2 To say
            w(1, ii - 1) = sh.Cells(i, ii).Value
        Next ii
        dic.Add sh.Cells(i, 1).Value, w
    Next i
    Set sh = Sheets("Chains")

    say = sh.Cells(Rows.Count, 4).End(3).Row

    If say < 2 Then Exit Sub
    lst = sh.Range("D2:D" & say).Value
    sh.Range("D2:D" & say).ClearContents

    For i = 1 To UBound(lst)
        If dic.exists(lst(i, 1)) Then
            al = Application.Transpose(dic(lst(i, 1)))
            say = UBound(al)
            sh.Cells(Rows.Count, 4).End(3).Offset(1).Resize(say).Value = al
        End If
    Next i
End Sub

Mehaba sayin @veyselemre ,

Kodu denedim fakat dic.Add sh.Cells(i, 1).Value, w satirinda su hatayi veriyor: "This key is already associated with an element of this collection"

Emeginiz icin cok tesekkurler.

 

[veyselemre]

Örneğin Bime ait veri 2 satırda geçiyorsa böyle bir hata alırsınız. Gönderdiğiniz dosyada tekrar olmadığı için bu şekilde yazıldı.