isme ait bilgilerin virgülle listelenmesi

[matozef]

Merhabalar
Bir film listesi mevcut, C sütunundaki yönetmen ismine göre, bu yönetmenin listede mevcut olan diğer filmleri (Fİlm isimleri A sütununda) virgülle (veya başka bir şekilde) D sütununda sıralansın
Umarım anlatabilmişimdir. Böyle bir durum mümkünmüdür bilmiyorum, makro kullanımı hakkındada en ufak bir fikrim yok. Yardımlarınız için şimdiden teşekkür ederim.
Çalışmalarınızda başarılar dilerim.

 

[fedeal]

merhaba,

Sub f()
Dim son As Long
son = Range("c65000").End(xlUp).Row
For i = 2 To son
For k = 2 To son
If Cells(i, 3).Value = Cells(k, 3).Value Then
Cells(i, 4).Value = Cells(i, 4).Value & " ; " & Cells(i, 1).Value
End If
Next
Next
End Sub

inceleyin istediginiz bumu?
saygılar.

 

[Korhan Ayhan]

Selamlar,

Alternatif olarak aşağıdakji kodu da kullanabilirsiniz. "FIND" komutu ile hazırladığım için daha hızlı sonuca ulaşabilirsiniz.

Option Explicit
 
Sub YÖNETMENE_AİT_TÜM_FİLMLER()
    Dim X As Long, BUL As Range, ADRES As String
    
    Application.ScreenUpdating = False
    Columns(4).ClearContents
    Columns(4).HorizontalAlignment = xlLeft
    
    For X = 2 To Range("C65536").End(3).Row
    Set BUL = Range("C:C").Find(Cells(X, 3))
    If Not BUL Is Nothing Then
    ADRES = BUL.Address
    Do
        If Cells(X, 4) = "" Then
        Cells(X, 4) = Cells(BUL.Row, 1)
        Else
        Cells(X, 4) = Cells(X, 4) & " , " & Cells(BUL.Row, 1)
        End If
    Set BUL = Range("C:C").FindNext(BUL)
    Loop While Not BUL Is Nothing And BUL.Address <> ADRES
    End If
    Next
    
    Set BUL = Nothing
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Necdet]

Merhaba,

Bende Korhan bey gibi Find komutu kullanmıştım ama başka bir sayfada listeledim, umarım bu da işinize yarayabilir.

Option Explicit
Sub Listele()
Dim i As Long
Dim c As Range
Dim Adres As String
Dim sa As Worksheet, so As Worksheet
Set sa = Sheets("AMERİKA&AVRUPA SİNEMASI")
Set so = Sheets("Özet")
sa.Select
Application.ScreenUpdating = False
so.Range("A2:B65536").ClearContents
Columns("C:C").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Özet").Range("A1"), Unique:=True
so.Select
For i = 2 To [A65536].End(3).Row
    With sa.Range("C:C")
        Set c = .Find(Cells(i, "A"), LookIn:=xlValues)
        If Not c Is Nothing Then
            Adres = c.Address
            Do
                If Cells(i, "B") = "" Then
                    Cells(i, "B") = sa.Cells(c.Row, "A")
                Else
                    Cells(i, "B") = Cells(i, "B") & "; " & sa.Cells(c.Row, "A")
                End If
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adres
        End If
    End With
Next i
Application.ScreenUpdating = True
MsgBox "Düzenleme Bitmiştir.....", vbOKOnly, "[URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL] Yardımlaşma Platformu"
End Sub

 

[matozef]

Yardımlarınız için çok teşekkürler.
Örneklerin herbiri oldukça kullanışlı, Geriye tercih etmek kaldı.
tekrar teşekkür ederim, elleriniz dert görmesin