Bir belgesel listesinde kişiyi seçip farklı bir liste oluşturmak

[karzer]

Konuyu doğru yeremi açtım bilmiyorum ama ben istediğimi yazayım...

Ben oluşturduğum bir belgesel listesini kişinin seçip farklı bir liste oluşturabilmesini istiyoum.Hemen kısaca anlayayım detayını

Tam olarak yapılmak istenen alttaki gibi...

--------------

Tam istediğim olay ise şu;Şöyle bir belgesel listem var:

A ile gösterilen yerlerinde seçme butonu gibi birşey olduğunu varsayalım.İşte bu seçilen Satırın ayrı bir yerde yeni bir liste olmasını istiyorum; Yani Seçilen Satırların oluşturcağı yeni bir liste(Resimdeki gibi)

Bide alttaki gibi kısa bir bilgi kısmı çıkarabilirmiyiz...

Şimdiden herkese Teşekkür Ederim.

 

[Levent Menteşoğlu]

Bir örnek dosya eklermisiniz.

 

[Orion1]

Merhaba.
Sayfa1'deki Rapor butonuna basınız.

Sub aktar()
Sheets("Sayfa1").Select
Set s2 = Sheets("Sayfa2")
Application.ScreenUpdating = False
s2.Range("A3:C65536").ClearContents
sat = 3
For i = 2 To Cells(65536, "B").End(xlUp).Row
    If Cells(i, "A").Value = "A" Or Cells(i, "A").Value = "a" Then
        adr1 = Range(Cells(i, "B"), Cells(i, "D")).Address
        adr2 = Range(Cells(sat, "A"), Cells(sat, "C")).Address
        s2.Range(adr2).Value = Range(adr1).Value
        sat = sat + 1
    End If
Next
Application.ScreenUpdating = True
Set s2 = Nothing
MsgBox "Aktarma tamamlandı..!!"
End Sub

 

[tahsinanarat]

Ekteki dosya size bu konuda fiker verecektir

Ekli dosyayı inceleyin, kendinize göre uyarlayıp kullanabilirsiniz, yada size bir fikir verecektir. Kolay gelsin

 

[karzer]

Teşekkür Ederim

Çok teşekkür ederim hocam...

Bunu kendi dosyama göre çalıştırmaya çalışacağım...:hey:

 

[karzer]

Son Bir istek

Teşekkürler...

peki biz burada sadece A yada a harfine basınca dosyayı seçebiliyoruz.Buna tüm karakterleri nasıl ekleyebilirim.

 

[Orion1]

Teşekkürler...

peki biz burada sadece A yada a harfine basınca dosyayı seçebiliyoruz.Buna tüm karakterleri nasıl ekleyebilirim.

Ekli dosyayı inceleyiniz.

Sub aktar()
Sheets("Sayfa1").Select
Set s2 = Sheets("Sayfa2")
Application.ScreenUpdating = False
s2.Range("A3:C65536").ClearContents
sat = 3
For i = 2 To Cells(65536, "B").End(xlUp).Row
    If Cells(i, "A").Value <> "" Then
        adr1 = Range(Cells(i, "B"), Cells(i, "D")).Address
        adr2 = Range(Cells(sat, "A"), Cells(sat, "C")).Address
        s2.Range(adr2).Value = Range(adr1).Value
        sat = sat + 1
    End If
Next
Application.ScreenUpdating = True
Set s2 = Nothing
MsgBox "Aktarma tamamlandı..!!"
End Sub

 

[karzer]

Çok Teşekkürler