Soru Belirli Kritere Göre Sayfalar arası Veri Çekme

[zozotr]

Üstadlar selamlar;
Öncelikle herkese sağlıklı ve mutlu bayramlar

Liste ve Ver isimlerinden oluşan iki sayfam var. Ver sayfasının A1 hücresinde yazanı Liste sayfasında tabloda bulup oradan 18 -20 farklı hücreden verileri Ver sayfasına aktarmak istiyorum.
Düşeyara ile yaptığımda sadece 1 adet veriyi alabiliyorum. Örnek dosyamı ekliyorum. Örnek dosyada olmasını istediğim gibi el ile yazdım. 5000 satırlık dosya da çalışıyorum. her defasında filtrele ve kopyala yapıştır zor oluyor.
Makro için yardımcı olabilecek üstadlardan rica ederim.

 

[ÖmerFaruk]

VER sayfasının kod sayfasına direkt yapıştırın. A1 hücresindeki tarihi değiştirince çalışacak.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, [A1]) Is Nothing Then Exit Sub
    If Not IsDate(Range("A1")) Then Exit Sub
    Veri = Worksheets("LİSTE").Range("A1").CurrentRegion.Value
    ReDim Liste(1 To UBound(Veri, 1) - 1, 1 To 20)
    For i = 2 To UBound(Veri)
        If Veri(i, 12) = Range("A1") Then
            Say = Say + 1
            Liste(Say, 1) = Say
            Liste(Say, 2) = Veri(i, 6)
            Liste(Say, 3) = Veri(i, 12)
            Liste(Say, 4) = Veri(i, 14)
            For k = 32 To UBound(Veri, 2)
            Liste(Say, k - 27) = Veri(i, k)
            Next k
        End If
    Next i
    Range("A3:XFD" & Rows.Count).ClearContents
    If Say = 0 Then Exit Sub
    Range("A3").Resize(Say, k - 28) = Liste
End Sub

 

[zozotr]

Sayın üstadım ÖmerFaruk;
Hızlı cevap için teşekkür ederim. Kod size attığım örnek dosyada çalışıyor. Ama kendi dosyama uyarladığımda kod hatası veriyor.
Sarı boyalı olarak Liste(Say, k - 27) = Veri(i, k) bu satırı veriyor. Örnek dosyada kod çalışıyor. Ana dosyamda çalışmadı
Sizden rica etsem bunu bu şekilde değilde daha farklı olarak Modül ekleyerek Göster butonu koysam ve o butona tanımlasam ayrıca temizle butonu ile de tablomda gerekli alanları temizlesem bunun için bana yardımcı olabilir misiniz acaba?
Teşekkürler tekrar

 

[ÖmerFaruk]

Ben kodları örnek dosyanıza göre yaptım. Arada ne fark var bilemediğim için yorum yapamıyorum.
Kodun aşağıdaki satırlarını silip butona atayabilrisiniz. Makroya bir ad da vermelisiniz.
If Intersect(Target, [A1]) Is Nothing Then Exit Sub
If Not IsDate(Range("A1")) Then Exit Sub

Temizlenecek alan doğru mu bilmiyorum. Zira ana dosyam farklı diyorsunuz.
Eğer ana dosyanıza uyarlayabilirseniz aşağıdaki kod satırını daTemizle butonunda kullanabilirsiniz.
Range("A3:XFD" & Rows.Count).ClearContents

 

[zozotr]

Sayın ÖmerFaruk Üstadım
Geç cevap verdiğim için kusura bakmayın lütfen.
Kodu Modül olarak denedim fakat yine hatalı
Hatanın ekran görüntüsünü koyuyorum.
Yardımcı olabilirseniz çok memnun olurum
Saygılarımla

Modül veya farklı şekilde olabilir.

 

[ÖmerFaruk]

LİSTE sayfasındaki kullandığınız aralığı görmüyorum. Gönderdiğiniz dosyaya göre hazırlanmış bir kod verdim ben. Siz farklılıkları belirtemezseniz ben onlarca tahminde bulunmak zorunda kalırım.

 

[zozotr]

Sayın ÖmerFaruk;

Liste Sayfam A3 ve BK sütunları arası aslında toplam 63 sütun var ve satır aralığı olarak da yaklaşık 3000 satır veri var. Bu ilerleyen dönemde daha da artabilir.
Söylediğinizi aynen yaptım. Örnek verdiğim dosya da AU sütununa kadardı. Çünkü almak istediğim kısımlar zaten bu aralıkta kalıyor.
Orjinal dosyam BK sütununa kadar devam ediyor. Ama o sütunlardan almam gereken veri yok.
Bu arada verileri Örnek dosyaya kopyaladığım zaman makro çalışıyor ama Orjinal dosyaya kodları uyguladığım zaman yukarıdaki hayatı veriyor.
Emekleriniz için çok teşekkür ederim.
Başka bir yolu varsa yol göstermenizi rica ederim
Saygılar

 

[ÖmerFaruk]

For k = 32 To UBound(Veri, 2) <---------
Liste(Say, k - 27) = Veri(i, k)
Next k

Kodun işaretlediğim yerdeki kırmızı kısım yerine sadece 47 yazın.

 

[zozotr]

For k = 32 To UBound(Veri, 2) <---------
Liste(Say, k - 27) = Veri(i, k)
Next k

Kodun işaretlediğim yerdeki kırmızı kısım yerine sadece 47 yazın.

Sayın ÖmerFaruk Üstadım.
Ellerinize sağlık. Kod bu haliyle çalışıyor.
Emekleriniz ve değerli vaktinizi ayırdığınız için çok teşekkür ederim
Saygılar