Makro İle Satılan/İade Edilen Kitapları Bir Hücrede Gösterme

[TASADAM366]

Değerli excelweb üyeleri.
Size gönderdiğim örnekte belirli kitapçılara satılan belirli kitaplar var.
Kitap isimleri C sutunundadır.Kitapçılar ise D3-AD3 aralığındadır.
Örneğimde eğer kitap ilgili kitapçıya satılmış ise Verildi ifadesi ile ve eğer kitap,geri iade edilmiş ise İADE ifadesiyle belirtilmiş.
Benim istediğim şu
Örnekte belirtilen her kitapçıya
hangi kitaplar satılmışsa o kitapların isimleri ilgili kitapçının bulunduğu sutunun en altında sıralansın.(D129,E129...AD129)
İade edilenler de hemen satılan kitapların listelendiği satırn bir altında listelensin.
(D130,E130...AD130)
Bu listelemedi boş olan(İADE ve VERİLDİ ifadesinin olmadığı) hücreler listelenmesin
Ayrıca listelemede kitaplar arasına sağında ve solunda birer boşluk olan virgül olsun.İsimler birbirine girmesin diye.Şunun gibi görünecek listede;
Kitap1 ; Kitap2 ; Kitap94

(Not:Ben birleştir formülüyle yapayım dedim ama boş olan hücrelere virgül ekliyor.Virgül koymasan bu sefer isimler birbirine giriyor.)
İlginiz ve yardımlarınız için imdiden teşekkkür ederim.Saygılarımla

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

Sub Listele()
    Dim sut As Integer, i As Integer, c As Range, d As Range, Adr As String
 
    sut = Cells(3, Columns.Count).End(xlToLeft).Column
 
    Application.ScreenUpdating = False
    Range(Cells(129, "D"), Cells(130, sut)).ClearContents
 
    For i = 4 To sut
        With Range(Cells(3, i), Cells(128, i))
            Set c = .Find("VERİLDİ", , xlValues, xlWhole)
            If Not c Is Nothing Then
                Adr = c.Address
                Do
                    Cells(129, i) = Cells(129, i) & " , " & Cells(c.Row, "C")
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            End If
            Set d = .Find("İADE", , xlValues, xlWhole)
            If Not d Is Nothing Then
                Adr = d.Address
                Do
                    Cells(130, i) = Cells(130, i) & " , " & Cells(d.Row, "C")
                    Set d = .FindNext(d)
                Loop While Not d Is Nothing And d.Address <> Adr
            End If
        End With
        Cells(129, i) = WorksheetFunction.Substitute(Cells(129, i), " , ", "", 1)
        Cells(130, i) = WorksheetFunction.Substitute(Cells(130, i), " , ", "", 1)
    Next i
 
    Application.ScreenUpdating = True
 
End Sub

.

 

[TASADAM366]

Ömer ilginize ve yardımlarınıza çok teşekkür ederim.Çok geç geri dönüş yaptığım içinde ayrıca özür dilerim.Verdiğiniz kod tam istediğim gibidir.
Şimdi sizden ve/veya diğer arkadaşlarımdan bir yardım daha istiyorum.Örnek2 dosyamda
Örnek1'e ilaveten iki yeni sutun eklenmiştir.Bu sutunlardan birinde Bu kitabı hangi kitapçı(lar) satın aldı? yazarken diğerinde ise Bu Kitabı hangi kitapçı(lar) geri iade etti? başlığı bulunmaktadır.
Benim istediğim şu.
Atanacak bir makro ile listedeki kitapları örneğin Kitap1'i hangi kitapçılar satın almışsa onları
Bu kitabı hangi kitapçı(lar) satın aldı? yazan sutunda D4 hücresinde göstersin.Bu gösterim tüm kitap çeşitleri için olsun.(Kitap2 D5'de,Kitap3 D6'da,...Kitap125 D128'de)
Yine bu aynı atanacak makro ile E sutununda, listedeki kitapları alıp ta geri iade eden kitapçıların isimlerini her bir kitap için yazsın.(Kitap2 E5'de,Kitap3 E6'da,...Kitap125 E128'de)
Son olarak makromuz kitapçıların isimleri arasına solunda ve sağında birer boşluk olan virgül de eklesin.İsimlerin birbirine girmemesi için.
Gönderdiğim örnekte nasıl olması gerektiğini göstermek için ilgili kitabı satın alan veya iade eden kitapçı isimlerini D4,D5 ve E4, E5 hücrelerin elle girerek gösterdim.
Yardımlarınız ve ilginiz için şimdiden teşekkür ederim.Saygılarımla

 

[TASADAM366]

Arkadaşlar bu konuda yardımınıza ihtiyacım var.Her zamanki gibi ilgi ve yardımlarınızı bekliyorum.Saygılarımla