Tüm kitapta arama ve yazma

[Arthassss]

İsteklerimi örnek dosya üzerindede açıklamaya çalıştım.
"D" sütünundaki benzersiz veriyi "A" ve "B" ismindeki sayfa1 ve sayfa2 hariç değişken sayıdaki sayfaların "G3" hücrelerinde (yada tüm sayfadada olabilir) arayıp eşleşme halinde verinin bulunduğu sayfanın "O2" hücresindeki veriyi eşleşen satırın "E:E" sutununa, "O6" hücresindeki veriyi eşleşen satırın "K:K" sutununa yazdırmak istiyorum. bunu eğer formül ile makro kullanmadan yapmak mümkün olursa daha iyi olur fakat makro ile yapılmasıda işimi görür. Makro ile yapılması halinde bir buton yada "D" sütununun seçilmesi ile "Worksheet_SelectionChange" veya benzeri bir komut ile tetiklenmesi sağlanabilir. İlgilenen arkadaşlara şimdiden teşekkür ederim.

 

[mesudiye_052]

Selamlar;
E4 Hücresine aşağıdaki formülü giriniz ve aşağıya doğru çoğaltınız.

=DOLAYLI(D4&"!O2")

Aynı şekilde K3 hücresine aşağıdaki formülü giripi çoğaltınız

=DOLAYLI(D4&"!O6")

 

[Arthassss]

İlginize çok teşekkür ederim.

 

[Arthassss]

Verdiğiniz formül doğru çalışıyor lakin sonradan farkettim aramayı sayfa isimlerinde yapıyor. Malesef bu şekilde benim işime yaramıyor. "D" sütunundaki veriyi tüm kitap içerisinde sayfaların adında değil sayfaların içlerinde özelliklle "G3" hücresinde (tüm sayfanın içerisindede olabilir ama o şekilde çok uzun süreceğinden sadece "G3" hücresinde olursa daha iyi olur.) aramasını ve işlem yapmasını istiyorum.
Örnek kitapta belirtmiştim aslında ama zannedersem gözünüzden kaçtı.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz. Kodu bir butona tanımlayıp kullanabilirsiniz.

Option Explicit
 
Sub SAYFALARDA_ARA()
    Dim S1 As Worksheet, X As Long, SAYFA As Worksheet, BUL As Range
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Sayfa3")
    S1.Range("E4:L65536").ClearContents
    
    For X = 4 To S1.Range("D65536").End(3).Row
        If S1.Cells(X, "D") <> "" Then
            For Each SAYFA In ThisWorkbook.Worksheets
                If SAYFA.Name <> "A" And SAYFA.Name <> "B" And SAYFA.Name <> S1.Name Then
                    Set BUL = SAYFA.Cells.Find(S1.Cells(X, "D"), LookAt:=xlWhole)
                    If Not BUL Is Nothing Then
                        S1.Cells(X, "E") = SAYFA.Range("O2")
                        S1.Cells(X, "K") = SAYFA.Range("O6")
                        Exit For
                    End If
                End If
            Next
        End If
    Next
 
    Set BUL = Nothing
    Set S1 = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Arthassss]

SN. AYHAN alakanıza teşekkür ederim.
Tam istediğim gibi oldu.
Yanlız farklı bir yerde 10 kadar sütun daha ilave etmem gerekebilir bunun için sadece
" S1.Cells(X, "K") = SAYFA.Range("O6")" ile başlayan kodları çoğaltmam yeterlimidir.

 

[Korhan Ayhan]

Selamlar,

Evet yeterlidir. Dilediğiniz kadar çoğaltabilirsiniz.

 

[Arthassss]

Kusura bakmayın çok oluyorum ama bir sorun daha fark ettim. Oda eğer "D" sütununda arada bir hücre boş ise o hücreye bir üstteki hücredeki değerin aynısını kopyalıyor bunun önüne geçmemiz mümkünmüdür. Yada şöyle söyleyim eğer d sütunu boş ise yada ordaki değer kitap üzerinde yok ise o satırı boş bıraksın.

 

[Korhan Ayhan]

Selamlar,

Üstteki mesajımdaki koda istediğiniz boş hücreleri atlama koşulu eklenmiştir. İncelermisiniz.

 

[Arthassss]

Sn AYHAN
Tekrar çok teşekkür ederim.
Tam olarak istediğim gibi oldu.
Saygılar...