sütundan çoklu veri arama ve hücreye yazdırma

[tolgahat]

http://resimyukle.duygusuz.com/image-DF1B_5719BCC4.jpg


Merhaba arkadaşlar. Ekteki resimde örneğini verdiğim işlemi yapmak istiyorum. Formül, verileri KAYNAK ve VERİLERİM sütununda arayıp, İSTEDİĞİM SONUÇ sütunununa yazdıracak.

Örnek olarak;

F3 hücresinin verisi A,C,D olduğu için J3 hücresine yazılmasını istediğim değer 1,3,4 olmalı. Çünkü;
A,B sütunundaki veirlere göre,

A=1
C=3
D=4

umarım anlatabilmişimdir derdimi.
Teşekkür eder iyi çalışmalar dilerim.

 

[YUSUF44]

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz:

Sub veriler()
On Error Resume Next
sonid = Cells(Rows.Count, "A").End(3).Row
sonveri = Cells(Rows.Count, "F").End(3).Row
yeni = 3
For veri = 3 To sonveri
    For cat = 1 To Len(Cells(veri, "F"))
        If Mid(Cells(veri, "F"), cat, 1) <> "," Then
            If Cells(yeni, "J") = "" Then
                Cells(yeni, "J") = WorksheetFunction.Index(Range("A3:A" & sonid), _
                WorksheetFunction.Match(Mid(Cells(veri, "F"), cat, 1), Range("B3:B" & sonid), 0))
            Else
                Cells(yeni, "J") = Cells(yeni, "J") & "," & WorksheetFunction.Index(Range("A3:A" & sonid), _
                WorksheetFunction.Match(Mid(Cells(veri, "F"), cat, 1), Range("B3:B" & sonid), 0))
            End If
        End If
    Next
yeni = yeni + 1
Next
    
End Sub

 

[tolgahat]

Teşekkürler YUSUF44,
Verdiğin kodları modül olarak çalışma sayfasına ekledim fakat daha sonrasına ne verileri nasıl yazdıracağımı anlayamadım.


Edit: Modülü çalıştır deyince oldu. Biraz inceleyip sonucu tekrar bildireceğim. Tekrar teşekkür ederim.

 

[tolgahat]

Tekrar merhaba YUSUF44,
Verdiğiniz çalışmayı ekteki örneğe uyarlamaya çalıştım fakat başarılı olamadım. Yardımlarınızı rica ederim.

İyi çalışmalar.

http://www.tolgahat.com/files/o.xlsx

 

[YUSUF44]

Asıl dosyanıza uyarlamak zor çünkü verdiğiniz örnekte veriler tek harften oluşuyordu, asıl dosyanızda ise harflerden değil kelimelerden oluşuyor. ilk dosyada parça al yöntemiyle her karakteri ayrı ayrı inceleyip sonucunu bulmuştum, şimdi öyle bir imkan yok. Kelimelerin uzunluğu sabit olmadığından kelimenin nerde başlayıp nerede bittiğini bulmak zor.

Yerinizde olsam dosyada A ve B sütununun yani kod ile isimlerin yerlerini değiştirirdim. F sütunundaki verilere de Metni Sütunlara Dönüştür işlemi uygulardım. Ondan sonra DÜŞEYARA formülü ya da yine makroyla çözüme ulaşırdım.

 

[veyselemre]

Sub test()
    With CreateObject("Scripting.Dictionary")
        For i = 3 To Cells(Rows.Count, "a").End(3).Row
            .Item(Cells(i, "b").Value) = Cells(i, "a").Value
        Next i
        For i = 3 To Cells(Rows.Count, "f").End(3).Row
            bol = Split(Cells(i, "f").Value, ",")
            For ii = 0 To UBound(bol)
                If .exists(bol(ii)) Then bol(ii) = .Item(bol(ii))
            Next ii
            Cells(i, "J").Value = Join(bol, ",")
        Next i
    End With
End Sub