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

Katılım
25 Eylül 2020
Mesajlar
2
Excel Vers. ve Dili
Excel 2013

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.)

 
Katılım
24 Nisan 2005
Mesajlar
3,671
Excel Vers. ve Dili
Office 2016 EN 64 Bit
Altın Üyelik Bitiş Tarihi
25/05/2022
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.


C++:
'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
 
Katılım
25 Eylül 2020
Mesajlar
2
Excel Vers. ve Dili
Excel 2013
Sen nasıl bir kralsın ya! Çok sağ ol Hocam...
 
Üst