Ayni Hucrede Birden Fazla Deger icin lookup

[ubay06]

Merhaba
Elimdeki excel tablosunda E sutunundaki hucrelerde rakamlar var ve herbir rakamin acilimi sheet 2 B sutununda belirtilmis. Sizden.ricam aralarinda _ isaretle ayrilan bu rakamlara karsilik gelen degerleri sutunlara bolup tek tek lookup yapmadan macro ile yapabilirmiyiz.

Teşekkürler

 

[askm]

Örnek dosyanızı ekleyebilir misiniz.

 

[ubay06]

Merhaba
Dosya yukleme inaktif mail adresinize gonderebilirmiyim

 

[ubay06]

http://www.upload.gen.tr/d.php/www/HgvB9/orncontent://media/external/file/151201ek-calisma.xlsx.html
Ben lookup yaptim fakat coklu alanlar hata verdi hücrelere ayirmadan macro ile cozebilirmiyiz.
Teşekkürler

 

[Orion1]

Dosyanız linktedir.

DOSYAYI İNDİR

Sub madde59()
Dim sh As Worksheet, sonsat1 As Long, sonsat2 As Long, adr As String, k As Range
Dim a, i As Long, j As Integer, deg As Long, deg2 As String
Sheets("Sheet1").Select
Range("B2:B" & Rows.Count).ClearContents
Set sh = Sheets("Sheet2")
sonsat1 = Cells(Rows.Count, "A").End(xlUp).Row
sonsat2 = sh.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To sonsat1
    a = Split(Cells(i, "A").Value, "_")
    For j = 0 To UBound(a)
        deg = a(j)
        Set k = sh.Range("A1:A" & sonsat2).Find(deg, , xlValues, xlWhole)
        If Not k Is Nothing Then
            deg2 = deg2 & "-" & k.Offset(0, 1).Value
        End If
    Next j
    deg2 = Right(deg2, Len(deg2) - 1)
    Cells(i, "B").Value = deg2
    deg2 = ""
Next i
MsgBox "İşlem Tamamdır." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[ubay06]

Elinize saglik cok tesekkur ederim.

 

[Orion1]

Elinize saglik cok tesekkur ederim.

Rica ederim.
İyi çalışmalar.