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

Katılım
16 Ekim 2009
Mesajlar
58
Excel Vers. ve Dili
2007 Türkçe
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...
 

Ekli dosyalar

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,496
Excel Vers. ve Dili
Ofis 365 Türkçe
Merhaba,

Pek anlamadım ama, kodları bir deneyiniz.

Kod:
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
 

Ekli dosyalar

Katılım
16 Ekim 2009
Mesajlar
58
Excel Vers. ve Dili
2007 Türkçe
İş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?
 
Katılım
16 Ekim 2009
Mesajlar
58
Excel Vers. ve Dili
2007 Türkçe
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...
 
Son düzenleme:

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,184
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
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.

.
 
Katılım
16 Ekim 2009
Mesajlar
58
Excel Vers. ve Dili
2007 Türkçe
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

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,184
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
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.

Kod:
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
.
 
Üst