Belli bir veriyi farklı sayfalarda arayıp bir yere getirmek

[klop01]

Arkadaşlar,
Üç sayfam var. Bu sayfalarda okuma kitaplarının adları yazıyor.
Başka bir sayfadaki F2 hücresine aradığım kitap adını yazdığımda diğer üç sayfada bu kitap varsa ona ilişkin bilgileri getirsin.

Ekli dosyada konuyu örnek oluşturarak net bir şekilde özetledim.
Yardımlarınızı rica ederim.

 

[Necdet]

Merhaba,
Formülle istemişsiniz ama Makrolu çözüm isterseniz diye bir seçenek sunayım dedim.
Not: Aranan kitap adını tam olarak girmeniz gerekmiyor.

Public Sub AraBulGetir()

Dim aranan As String
Dim sh As Worksheet
Dim i As Long
Dim c As Range
Dim adr As String

Sayfa1.Range("A1").CurrentRegion.Offset(1).ClearContents
aranan = Sayfa1.Range("F2")

If aranan = "" Then
    MsgBox "Aranan Kitap Boş"
    Exit Sub
End If

i = 1

For Each sh In Worksheets
    If sh.Name Like "EDEB*" Then
        With sh.Range("B:B")
            Set c = .Find(aranan, LookIn:=xlValues)
            If Not c Is Nothing Then
                adr = c.Address
                Do
                    i = i + 1
                    Sayfa1.Cells(i, "A") = sh.Name
                    Sayfa1.Cells(i, "B") = sh.Cells(c.Row, 1)
                    Sayfa1.Cells(i, "C") = sh.Cells(c.Row, 2)
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> adr
            End If
        End With
    End If
Next sh


End Sub

 

[klop01]

Necdet Bey,
Teşekkür ederim, yazılan makro işlemi hatasız yapıyor. Ek olarak tam isim girmeden de arama yapılabiliyor olması iyi oldu. Formülle olsa iyi olacak aksi durumda bu makroyu kullanacağız artık.
Sağ olun.

 

[Necdet]

Biraz daha işinizi kolaylaştıralım.
Sadece kitap değil, yazar ya da yayın evi aramasını da yaptıralım.

Public Sub AraBulGetir()

Dim aranan As String
Dim sh As Worksheet
Dim i As Long
Dim c As Range
Dim adr As String

Sayfa1.Range("A1").CurrentRegion.Offset(1).ClearContents
aranan = Sayfa1.Range("G2")

If aranan = "" Then
    MsgBox "Aranan Kitap Boş"
    Exit Sub
End If

Application.ScreenUpdating = False

i = 1

For Each sh In Worksheets
    If sh.Name Like "EDEB*" Then
'        With sh.Range("B:B")
        With sh.Columns(Range("H2"))
            Set c = .Find(aranan, LookIn:=xlValues)
            If Not c Is Nothing Then
                adr = c.Address
                Do
                    i = i + 1
                    Sayfa1.Cells(i, "A") = sh.Name
                    Sayfa1.Cells(i, "B") = sh.Cells(c.Row, 1)
                    Sayfa1.Cells(i, "C") = sh.Cells(c.Row, 2)
                    Sayfa1.Cells(i, "D") = sh.Cells(c.Row, 3)
                    Sayfa1.Cells(i, "E") = sh.Cells(c.Row, 4)
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> adr
            End If
        End With
    End If
Next sh

Columns("A:E").EntireColumn.AutoFit
Application.ScreenUpdating = True

End Sub