Kritere uyanları tek hücreye aktarmak

[ynmcan]

Merhaba arkadaşlar;

"A" sütunundaki isimleri, yanındaki hücredeki kritrelere göre tek hücreye aktarmak istiyorum, ancak bir türlü yapamadım. Yardımcı olursanız sevinirim.

Örnek dosyam ekte.

 

[Orion1]

Dosyanız ektedir.

Sub aktar_59()
Dim z As Object, hcr As Range, sat As Long, i As Long
Sheets("Sayfa1").Select
Range("E4:E5,G4:G5").ClearContents
sat = Cells(65536, "B").End(xlUp).Row
Application.ScreenUpdating = False
Set z = CreateObject("Scripting.Dictionary")
For i = 1 To sat
    If Cells(i, "B").Value <> "" Then
        If Not z.exists(Cells(i, "B").Value) Then
            z.Add Cells(i, "B").Value, Cells(i, "A").Value
            Else
            z.Item(Cells(i, "B").Value) = z.Item(Cells(i, "B").Value) & "," & Cells(i, "A").Value
        End If
    End If
Next
For j = 4 To 6 Step 2
    For i = 4 To 5
        If z.exists(Cells(i, j).Value) Then Cells(i, j + 1).Value = z.Item(Cells(i, j).Value)
    Next
Next
Application.ScreenUpdating = True
MsgBox "İşlem tamamdlr." & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation
End Sub

 

[tukayf]

önce ben teşekkür edeyim hocam. zihninize sağlık. dolaşırken buldum epey işime yarayacak. ayrıca çok erkencisiniz.

 

[ynmcan]

Syn. Evren Gizlen;
Elinize zihninize sağlık. Teşekkür ederim.