Düşeyara da birden fazla sonuç listeleme

[SBAYSAL]

Merhaba,
Bulunan sonuç birden fazla ise bunları aynı hücreye virgülle ayırarak nasıl yazdırabilirim?

 

[Ömer]

Merhaba,

Aynı hücrede olacaksa, bu işlem için formül kullanmanızı tavsiye etmem, makro ile yapmak mantıklı olacaktır. Örnek dosya ekler misiniz, örnek üzerinden gidelim.

 

[SBAYSAL]

Merhaba,

Aynı hücrede olacaksa, bu işlem için formül kullanmanızı tavsiye etmem, makro ile yapmak mantıklı olacaktır. Örnek dosya ekler misiniz, örnek üzerinden gidelim.

Nasıl dosya yükleniyor buraya bulamadım

 

[Ömer]

Dosya Yükle - Dosya Upload

Dosyalarınızı ücretsiz yükleyebilir ve paylaşabilirsiniz. Dosya yükleme, Dosya Upload ücretsiz.

dosya.co

Sitesine yükleyip indirme adresini paylaşabilirsiniz. Yada Altın üye olarak direk siteye yükleyebilirsiniz.

 

[SBAYSAL]

İndir Düşeyara

Dosyayı indir Düşeyara

dosya.co

 

[Ömer]

Aranacak veri sayfası A sütununa girilecek tüm veriler içindir.

Linki inceleyin.

İndir Duseyara Kopya

Dosyayı indir Duseyara Kopya

dosya.co

Sub bul()
   
    Dim Sv As Worksheet, Sy As Worksheet
    Dim ayr As String, i As Long, c As Range, Adr As String
       
    Set Sv = Sheets("Aranacak veri")
    Set Sy = Sheets("Aranılacak yer")
       
    Application.ScreenUpdating = False
    Sv.Select
    Range("B2:B" & Rows.Count).ClearContents
   
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        Set c = Sy.[A:A].Find(Cells(i, "A"), , xlValues, xlWhole)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                If Cells(i, "B") = "" Then ayr = "" Else ayr = ";"
                Cells(i, "B") = Cells(i, "B") & ayr & Sy.Cells(c.Row, "B")
                Set c = Sy.[A:A].FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    Next i
   
End Sub

 

[SBAYSAL]

Aranacak veri sayfası A sütununa girilecek tüm veriler içindir.

Linki inceleyin.

İndir Duseyara Kopya

Dosyayı indir Duseyara Kopya

dosya.co

Sub bul()
   
    Dim Sv As Worksheet, Sy As Worksheet
    Dim ayr As String, i As Long, c As Range, Adr As String
       
    Set Sv = Sheets("Aranacak veri")
    Set Sy = Sheets("Aranılacak yer")
       
    Application.ScreenUpdating = False
    Sv.Select
    Range("B2:B" & Rows.Count).ClearContents
   
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        Set c = Sy.[A:A].Find(Cells(i, "A"), , xlValues, xlWhole)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                If Cells(i, "B") = "" Then ayr = "" Else ayr = ";"
                Cells(i, "B") = Cells(i, "B") & ayr & Sy.Cells(c.Row, "B")
                Set c = Sy.[A:A].FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    Next i
   
End Sub

 

[Ömer]

Linkteki örnekte kodları eklemiştim butona basmanız yeterli. Alt+F11 yaparsanız kodları Module sayfasında görebilirsiniz.

 

[SBAYSAL]

süpersiniz,çok teşekkürler.

 

[Ömer]

Rica ederim, işinize yaradığına sevindim.