Aranan bir değeri belirli bir aralıkta bulup sıra ile yazdırmak...

[trmusic]

Merhabalar,

Başlıkta da belirttiğim gibi aranan bir değeri belirli bir aralıkta bulup sıra ile yazdırmak istiyorum, üç farklı sekme kullanıyorum "Giriş", "Seçim" ve "Yazdır" sekmeleri.

"Giriş" sekmesi:
A1[Ahmet], B1[Ahmet], C1[Mehmet], D1[Ahmet], E1[Ayşe], F1[Ahmet]
A2[AKIN], B2[ŞANLI], C2[YÜCE], D2[ULU], E2[BAŞAR], F2[ŞAŞMAZ]

"Seçim" sekmesi
A1[Ahmet]

"Yazdır" sekmesi:
A1[1]
A2[2]
A3[3]
A4[4]
A5[5]
A6[6]
A7[7]
A8[8]
A9[9]
A10[10]

"Giriş" sekmesine veri girişi yapılıyor.
"Seçim" sekmesinden verilerinin aktarılması istenilen hücre değeri seçiliyor.
"Yazdır" sekmesi "Seçim" sekmesindeki belirlenen hücre içinde bulunan değeri "Giriş" sekmesinde arıyor ve soldan - sağa doğru bulduğu aynı değerlere göre sırayı algılayıp "Yazdır" sekmesinin içine yukarıdan aşağıya doğru altındaki bilgileri yan yana sıralıyor.

İstenilen sonuç:
"Seçim" sekmesi A1 hücresinde bulunan "Ahmet" değeri "Giriş" sekmesinin 1'inci satırında aranacak ve altına yazılan bilgiler sıra ile "Yazdır" sekmesine çıkartılacak.

İşlem sonucu "Yazdır" sekmesindeki görünüm şöyle olmalıdır;
A1[1], B1[AKIN]
A2[2], B2[ŞANLI]
A3[3], B3[ULU]
A4[4], B4[ŞAŞMAZ]
A5[5], B5[]
A6[6], B6[]
A7[7], B7[]
A8[8], B8[]
A9[9], B9[]
A10[10], B10[]

Bu uygulama için hazırlanmış örnek Excel dosyası EK'te sunulmuştur. Sorunumun yanıtını formül ve/veya macro kullanarak yapmamda yardımcı olursanız çok sevinirim, şimdiden teşekkürler...

 

[Necdet]

Merhaba,

Pek anlamadım ama, kodları bir deneyiniz.

Sub Bul_Yaz()
 
    Dim c       As Range, _
        Adr     As String, _
        Aranan  As String, _
        i       As Integer, _
        sg      As Worksheet, _
        ss      As Worksheet, _
        sy      As Worksheet
 
    Set sg = Sheets("Giriş")
    Set ss = Sheets("Seçim")
    Set sy = Sheets("Yazdır")
    Aranan = ss.Range("A1")
    i = 0
    Application.ScreenUpdating = False
    sy.Range("B:B").ClearContents
 
    With sg.Range("1:1")
        Set c = .Find(Aranan, LookIn:=xlValues)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                i = i + 1
                sy.Cells(i, "B") = sg.Cells(2, c.Column)
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    End With
 
    MsgBox "Bulunanlar Yazıldı..."
    sy.Select
 
End Sub

 

[trmusic]

İşte tam olarak aradığım şey buydu, çok teşekkürler... Macro konusunda deneyimsiz olduğum için çok olmamış olacaksam bunu uzatmanın yöntemini de sorabilir miyim? Yani 2. satırdan sonrasını da devamına yazdırması için ne gereklidir?

 

[citiboyy]

Merhaba
Bende makrosuz yaptım alternatif olsun ..

 

[trmusic]

Size de teşekkür ederim "citiboyy", bu arada ufak bi karıştırma ile makro ile çoğaltma yöntemini "(sy.Cells(i, "B") = sg.Cells(2, c.Column)" satırını çoğaltıp isteğe göre "sy.Cells(i, "c") = sg.Cells(3, c.Column)" gibi yaparak çözdüğümü düşünüyorum daha pratik ve farklı bir yol var ise paylaşırsanız sevinirim, teşekkürler tekrardan...

 

[Ömer]

Merhaba,

Satır sayısı sabit mi yoksa değişken mi? Eğer sabit ve az ise ekleme yapılır fakat değişken ve çok ise döngü kurmak gerekir. Bilgi verirseniz ona göre yeniden düzenlemeye çalışırım.

.

 

[trmusic]

Merhaba,

Satır sayısı sabit mi yoksa değişken mi? Eğer sabit ve az ise ekleme yapılır fakat değişken ve çok ise döngü kurmak gerekir. Bilgi verirseniz ona göre yeniden düzenlemeye çalışırım.

.

Merhabalar;

İlgilendiğiniz için teşekkür ederim. Sabit değil, eklenebilir olacak buna göre yardımcı olursanız sevinirim. Teşekkürler...

 

[Ömer]

Merhabalar;

İlgilendiğiniz için teşekkür ederim. Sabit değil, eklenebilir olacak buna göre yardımcı olursanız sevinirim. Teşekkürler...

Kodları aşağıdakilerle değiştiriniz.

Sub Bul_Yaz()
 
    Dim c       As Range, _
        Adr     As String, _
        Aranan  As String, _
        i       As Integer, _
        sg      As Worksheet, _
        ss      As Worksheet, _
        sy      As Worksheet, _
        son     As Long
 
    Set sg = Sheets("Giriş")
    Set ss = Sheets("Seçim")
    Set sy = Sheets("Yazdır")
 
    Aranan = ss.Range("A1")
    i = 0
 
    Application.ScreenUpdating = False
    sy.Range("B1", sy.Cells(Rows.Count, Columns.Count)).ClearContents
 
    With sg.Range("1:1")
        Set c = .Find(Aranan, LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                i = i + 1
                son = sg.Cells(Rows.Count, c.Column).End(xlUp).Row
 
                sg.Range(sg.Cells(2, c.Column), sg.Cells(son, c.Column)).Copy
                sy.Cells(i, "B").PasteSpecial xlPasteValues, xlNone, False, True
                Application.CutCopyMode = False
 
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    End With
 
    MsgBox "Bulunanlar Yazıldı..."
    sy.Select
 
End Sub

.