Sayfalar arası Koşullu veri Aktarımı

[ademb28]

Üstadlardan Ricam,

-Gelişmiş filtre ile Sayfalar arası veri aktarımı yapıyorum ama benim istediğim aktarımların alt alta gelmesi.Gelişmiş filtre farklı satırlara aktarım yapmakta.

-Ayrıca sadece "diğer" sayfasındaki veriyi bir satır boşluk bırakılarak bir alt satıra aktarılması.

-Şöyle bir durum da var. ben buna uygun dosyayı Excel 2010 da kullanıyorum.data ikiyüzbin satır.Gelişmiş filtre ile yaptığımdan en az 5 dk.bekletiyor.Daha hızlı şekilde alınabilmesi sağlanırmı?

Gerekirse dosyayıda eklerim.

Sub Makro1()
'
' Makro1 Makro
' Makro Adem tarafından 02.12.2012 tarihinde kaydedildi.
'

'


    Sheets("HEPSİ").Select
    Columns("D:P").Select
    Selection.Delete Shift:=xlToLeft
    Range("D1").Select
    If Range("a2") = 99 Then
    Range("a2").Delete
    End If
    
    If Range("a2") < 99 Then
    
    
    
    
    Sheets("sayfa1").Range("A2:M17").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range("A1:A2"), CopyToRange:=Range("D3"), Unique:=False
    
    Sheets("sayfa2").Range("A2:M17").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range("A1:A2"), CopyToRange:=Range("D25"), Unique:=False
        
    Sheets("sayfa3").Range("A2:M17").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range("A1:A2"), CopyToRange:=Range("D40"), Unique:=False
        
    Sheets("Diğer").Range("A2:M17").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range("A1:A2"), CopyToRange:=Range("D65"), Unique:=False
    End If
   
End Sub

Yardımcı olan ve yol gösteren tüm arkadaşlara şimdiden teşekkürlerimi sunuyorum.

 

[Civan Jack]

Dosyayı ekleyin ve ne yapmak istediğinizi dosya üzerinde belirtin.

 

[ademb28]

Dosya eklenmiştir.

 

[Civan Jack]

A2 hücresine bir değer girdiğinizde çalışır. Q3 hücresine Sayfa yazın.
Sayfanın kod kısmına şu kodları yapıştırın;

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim syf As Worksheet
    Dim evn As Range
    If Target.Address(0, 0) <> "A2" Then Exit Sub
    Range("D4:Q65536").ClearContents
    For Each syf In Worksheets
    If syf.Name <> "HEPSİ" Then
    Set evn = syf.Columns(1).Find(Target.Value, , , 1)
        If Not evn Is Nothing Then
            If Target.Value = 99 Then
                syf.Range("A3:L" & syf.Range("L65536").End(3)).Copy Range("D65536").End(3)(2, 1)
                    Else
                evn.Resize(, 13).Copy Range("D65536").End(3)(2, 1)
                Range("Q65536").End(3)(2, 1) = syf.Name
            End If
        End If
    End If
    Next syf
    Set evn = Nothing: Set syf = Nothing
End Sub

 

[ademb28]

Üstad Teşekkür ederim,emeğine sağlık.
Diğer sayfasındaki verinin bir satır boşluk bırakılarak bir alt satıra yazdırılması kısmını halledebilirsek sevinirim.(şu anda o ayrımı yapamıyorum)

 

[ademb28]

Üstad Civan Jack, A2 Hücresine 99 yazdığımızda bütün verileri getirirken 99 dan küçük olanların bilgilerini ise her sayfadan 1 tane getirmektedir.

 

[ademb28]

Üstad, A2 Hücresine 99 yazdığımızda bütün verileri getirirken 99 dan küçük olanların bilgilerini ise her sayfadan 1 tane veri getirmektedir.
Ayrıca Diğer sayfasındaki verinin bir satır alta getirilmesi konusunda yardımcı olabilirsen sevinirim.

 

[ademb28]

Civan Jack üstadın yazdığı kodda yardım;

-A2 Hücresine 99 girdiğimizde bütün verileri getiriyor gözükmesine rağmen eksik veri getirmektedir.

-99 dan küçük olanların bilgilerini ise her sayfadan 1 tane veri getirmektedir.

 

[ademb28]

Konu hakkında bilgisi olan varmı?

 

[ademb28]

Konuya cevap verildi ama eksiklikler mevcut.Eksikliklerin giderilmesi konusunda son kez mesajı güncel hale getiriyorum.sonra konuyu kapatmayı düşünüyorum.

Teşekkürler....