Bir sütundakiler arasında birden çok değer bulma

[Tevfik_Kursun]

Günaydın Arkadaşlar,
Code içindeki Bul makrosu A1 hücresine yazılı ismi B5:B11 arasında bulup sağındaki ve onunda sağındaki ile birlikte F1, G1 hücrelerine yazıyor.
B5:B11 arasında A1 de yazılı olan 1 den fazla ise diğerlerini de benzer şekilde bulup F2, G2 ye, F3, G3 e, ... yazdırabilmek için bu kodlara ne eklemeliyim?

Sub Bul()
  Range("B5:B11").Select
    Selection.Find(What:=[A1], After:=ActiveCell, LookIn:= _
    xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
    xlNext, MatchCase:=False, SearchFormat:=False).Select
    ActiveCell.Offset(0, 1).Select: Selection.Copy: Range("F1").Select: ActiveSheet.Paste

  Range("B5:B11").Select
    Selection.Find(What:=[A1], After:=ActiveCell, LookIn:= _
    xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
    xlNext, MatchCase:=False, SearchFormat:=False).Select
    ActiveCell.Offset(0, 2).Select: Selection.Copy: Range("G1").Select: ActiveSheet.Paste
  Range("A1").Select
End Sub

Saygılarımla

http://s2.dosya.tc/server5/a1nggw/Ornek82_TK.rar.html

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Bul_Listele()
    Dim Aranan As Variant, Bul As Range, Adres As String, Satir As Long, Hesaplama_Tipi As Long
    
    Application.ScreenUpdating = False
    Hesaplama_Tipi = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Aranan = Range("A1").Value
    
    Range("F:G").Clear
    Satir = 1
    
    Set Bul = Sheets("Sayfa1").Range("B5:B13").Find(Aranan, , , xlWhole, , xlPrevious)
    If Not Bul Is Nothing Then
        Adres = Bul.Address
        Do
            Cells(Satir, "F") = Bul.Offset(0, 1).Value
            Cells(Satir, "G") = Bul.Offset(0, 2).Value
            Satir = Satir + 1
            Set Bul = Sheets("Sayfa1").Range("B5:B13").FindNext(Bul)
        Loop While Not Bul Is Nothing And Bul.Address <> Adres
    End If
    
    Application.ScreenUpdating = True
    Application.Calculation = Hesaplama_Tipi
    
    If Satir - 1 = 0 Then
        MsgBox "Aranan kayıt bulunamadı!", vbCritical
    Else
        MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & Satir - 1 & " adet kayıt bulunmuştur.", vbInformation
    End If
End Sub

 

[Tevfik_Kursun]

Sayın Korhan Ayhan Hocam,
İlginize çok teşekkür ederim.
Saygılarımla