Çalışma kitabında sözcük aratarak, sözcüğün bulunduğu tüm satırları boş sayfaya yapıştırma

[Kolej Hocası]

Merhabalar,

Excel 2013'te; bazı öğrenci isimlerini birçok çalışma sayfasından soyadlarını aratarak tek tek bulup bu öğrencilerin satır bilgilerini kopyalayarak bir başka boş tabloya yapıştırmam gerekiyor. Bunun için bir formül oluşturabilir miyim? (Kabaca sözel olarak ifade etmek gerekirse; çalışma kitabında "CİVAN" sözcüğünün bulunduğu tüm satırları şuraya yapıştır.)

 

[Asri]

Makrolu çözüm;
1. sayfayı kontrol etmez.
Diğer sayfalarda bulduklarını 1. sayfaya 2. satırdan itibaren yazar.

1. sayfa B1 hücresine aranacak kelime yazılır.
1 yazıldığında 1 yada 11 bulundu olarak algılanır. Eşleştirme tam değil içerir şeklinde yapılır.

Bulgetir.xlsm

1 file sent via WeTransfer, the simplest way to send your files around the world

we.tl

'https://stackoverflow.com/questions/19504858/find-all-matches-in-workbook-using-excel-vba

Sub bulgetir()
Dim wSh As Worksheet
Dim foundCells As Range
satir = 1
For i = 2 To Sheets.Count
    Set wSh = Sheets(i)
    Set foundCells = FindAll(wSh.UsedRange, Range("B1").Value)
    If Not foundCells Is Nothing Then
        Dim cell As Range
        For Each cell In foundCells
           satir = satir + 1
           wSh.Rows(cell.Row & ":" & cell.Row).Copy Sheets(1).Rows(satir & ":" & satir)
        Next
    End If
Next

End Sub


Function FindAll(ByVal rng As Range, ByVal searchTxt As String) As Range
    Dim foundCell As Range
    Dim firstAddress
    Dim rResult As Range
    With rng
        Set foundCell = .Find(What:=searchTxt, _
                              After:=.Cells(.Cells.Count), _
                              LookIn:=xlValues, _
                              LookAt:=xlPart, _
                              SearchOrder:=xlByRows, _
                              SearchDirection:=xlNext, _
                              MatchCase:=False)
        If Not foundCell Is Nothing Then
            firstAddress = foundCell.Address
            Do
                If rResult Is Nothing Then
                    Set rResult = foundCell
                Else
                    Set rResult = Union(rResult, foundCell)
                End If
                Set foundCell = .FindNext(foundCell)
            Loop While Not foundCell Is Nothing And foundCell.Address <> firstAddress
        End If
    End With

    Set FindAll = rResult
End Function

 

[Kolej Hocası]

Sen nasıl bir kralsın ya! Çok sağ ol Hocam...