arabul sayfa ıkıye lıstele

[atillahun]

ekteki dosyada koda gore aratıp 2 sayfaya lıstelme işlemi yaptım liste olusuyor
ama yazdıgım makronun ıcınde arama yaptırabılıyorum sadece her aramada makroya gıdıp arama kodunu degıstırıyorum bunu butonla yaada he hangı bır hucrede arama kodunu oraya yazarak lıstele yapabılırmıyım yardımcı olablen arkdaşlara şimdiden cok teşşekkur ederim

not arama kodunu b sutunundakılerı yanda lıstbox dan secerek 2 sayfaya yazdırabılırsek cok guzel olurdu ama hucreye yazarak aramada olur .
herkeze teşşekur ederim ıykı bu sıte var :

 

[Murat OSMA]

Lütfen ne yapmak istediğinizi daha net anlatmaya çalışır mısınız ?

 

[atillahun]

ekteki dosyada 2 harfli kodların oldu bolumde DH AH gibi bu sundakı farklı kodları
sayfa 2 de koda gore mesela DH kodunu ara sayfa 2 ye listele bunu yaptım ama
sayfa1 de kod goruntule dersenız yadıgım kodlarda ara bul fonksıyonunu kodu degıstırerek yapıyorum buda pratık olmuyor eger bu arama fonksıyonunu
secenek vasıtasıyla mesela sayfa bır de arama krıterını belırlesem hucereye bh yazıp aktar degımde sayfa 2 ye aktarsa nasıl olur ugrastım ama bulamadım

 

[atillahun]

Sub Bul_Aktar()

Dim S2 As Worksheet, sat As Long, c As Range, Adr As String

Set S2 = Sheets("Sayfa2")

Application.ScreenUpdating = False
Sheets("Sayfa1").Select

S2.Range("A2:C" & Rows.Count).ClearContents

sat = 2
With Range("B2:B" & Rows.Count)
Set c = .Find("DH")
If Not c Is Nothing Then
Adr = c.Address
Do
Range("A" & c.Row & ":G" & c.Row).Copy S2.Cells(sat, "A")
sat = sat + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> Adr
End If
End With

End Sub*****************************************************************
burda fınd (hd) ara dıye yapabıldım ama her degısık kodda buraya gırıp arama krıterını degıstırmem gerek ben sayfa bırde herhangı bır yerde bu kodu yazarak ara ve sayfa 2 ye lıstele yapmak ıstıyorum .

 

[Murat OSMA]

C1 hücresine listeletmek istediğiniz kodu yazın.

Kodunuzu da şöyle yapın;

[SIZE="2"]Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S2 As Worksheet, sat As Long, c As Range, Adr As String
    
    If Target.Address(0, 0) = "C1" Then
    Set S2 = Sheets("Sayfa2")
 
    Application.ScreenUpdating = False
    Sheets("Sayfa1").Select
 
    S2.Range("A2:G" & Rows.Count).ClearContents
 
    sat = 2
    With Range("B2:B" & Rows.Count)
        Set c = .Find(Target.Value)
                If Not c Is Nothing Then
            Adr = c.Address
            Do
                Range("A" & c.Row & ":G" & c.Row).Copy S2.Cells(sat, "A")
                sat = sat + 1
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    End With
    End If
End Sub[/SIZE]

 

[Murat OSMA]

Şu kodu da kullanabilirsiniz;

[SIZE="2"]Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Integer
    If Target.Address(0, 0) = "C1" Then
        For i = 2 To Range("C65536").End(3).Row
            Sayfa2.Cells(i, 1).Resize(, 7).ClearContents
            If Target.Value = Cells(i, "C") Then
                Cells(i, 1).Resize(, 7).Copy Sayfa2.Cells(i, 1).End(3)(2, 1)
            End If
        Next i: End If
    i = Empty
End Sub[/SIZE]

 

[atillahun]

cevabın için cok teşekkur ederim ama bunu çalıstıramadım bunu benım yazdıgım koda mı eklıcem yoksa senın vergınlemı çalıstırıcam ama olede denedım olmadı

 

[atillahun]

MURAT kardesım cok sağ ol yaptım kodu yanlış yere yazdım ondan olmadı sanrım duzelttım
ellerin dert gormesin cok teşşekkur ederim . atillahun
allaha emanet ol

 

[Murat OSMA]

Lütfen düzgün Türkçe yazın.
Vallahi mesajınızı okumak bile içimden gelmedi...:bad:

Bunu çalıştıramadım dediğiniz hangisi ?
İlk verdiğim kodu sizin kodunuzla değiştirin.
Dilerseniz ikinci verdiğim kodu da kullanabilirsiniz...

 

[zafer]

Merhaba


Bilgilerinizin olduğu sayfa örnek sayfa1 yazısı üzerindeyken sağ fare tuşuna basın gelen menüde Kod görüntüleyi seçin.

Gelen ekranda Sn.Murat beyin 2 adet yazmış olduğu kod'dan birini kopyalayın.

Sayfa1 üzerinde C1 hücresine ne girerseniz B sütununda bulup 2.sayfaya aktarır.

 

[Murat OSMA]

Çözdüğünüze sevindim, iyi günler...

 

[Murat OSMA]

Desteğiniz için teşekkürler Zafer Bey...

 

[atillahun]

özür dilerim acele yazdım bozuk çıkmış kelimeler ama çok teşşekkür ederim
verdiğini biraz daha geliştirdim açılır pencereden kod seçerek arama yapabiliyorum
seni yordum sanrım hakkını helal et allaha emanet

 

[Murat OSMA]

Bazen kelimeler böyle bozuk çıkabiliyor, sizi anlıyorum...
Ne güzel, daha iyisini yapmışsınız.

 

[zafer]

Merhaba

Desteğiniz için teşekkürler Zafer Bey...

Rica ederim.Her zaman birbirimizin desteğine ihtiyacımız var.

Baktım siz sitede yoktunuz sizin yazacaklarınızı ben yazdım. :arkadas:

İyi çalışamalar

 

[Murat OSMA]

Muhakkak ki öyle...

Teşekkür ederim, size de iyi çalışmalar...