Geniş bir listeden kritere göre toplu satır kopyalama

[andruil]

Merhaba arkadaşlar,

280.000 satırlık bir listem var. Toplamda 18.000 küsürlük müşteri numarasından oluşmakta ve bir müşteri numarasından da 10'dan fazla satır bulunmakta farklı detaylar ile birlikte.

Ekte küçük bir örnek oluşturdum. Bir müşteri numarasından 2015 yılı Ocak ayı Nakdi borç için bir satır var ve aynı müşteri için 2015 Yılı Şubat ayı Nakdi borç için ayrı bir satırı var gibi değişik satırlar.

Benim istediğim şu;
18.000 küsür müşteri içerisinden benim aradığım 5.000 küsürlük bir müşteri var. Bunları süzmem gerekiyor tüm satırları ile birlikte. Yani bu müşteri numarasını ilgilendiren tüm satırları almam lazım.

Vlookup yapma şansım yok çünkü bir müşteri numarasından birden fazla tekrarı var. İndex Match yapsam ya da Sumifs yapsam 280.000 satır için her hücresine formül yazsam 5.000 müşteri için sanırım excelin hesaplaması 1 hafta sürer.

Bunu makro ile yapmak istiyorum.
Kafamda oluşturduğum mantık basit ama formüle edemiyorum.

Mantık şu olsa yeter;
Elimde olan müşteri numarasını, kaynak içerisinde arasın ve onunla ilgili olan satırın tamamını diğer sayfaya yapıştırsın. Eğer o müşteri numarasını ilgilendiren 10 satır varsa hepsini kopyalaması gerekiyor.

Yardımcı olabilecek arkadaşlara şimdiden çok teşekkür ederim.

Excel'de Kaynak, Hedef ve Sonuç şeklinde sayfalar oluşturdum. Ayrı sayfalar olarak dikkate alınırsa sevinirim.

 

[Mehmet Şahin]

Merhaba,
performans ne olur bilemem ama
bir deneyiniz.
İyi çalışmalar.

 

[andruil]

Merhaba,
performans ne olur bilemem ama
bir deneyiniz.
İyi çalışmalar.

dosya eklemeyi unuttunuz sanırım

 

[Mehmet Şahin]

Şimdi ekledim.

 

[merakli_72]

selam,
istediğinizin nerdeyse aynısı olan bir çalışma daha once yapıldı,
hatta bir kaç çözüm önerisi içindende en performanlısı bulundu (onda da kayıt sayısı sizinki gibi fazlaydı)
Sanırım en performanslı çözüm kaynak tabloda kayıtların içinde istenen şartı göre süzme yapmak ve süzülen kayıtları hedef sayfaya yapıştırmak şeklinde olan makroydu

Konu başlığını hatırlayamadım , ama dikkatli bir aramada bulabileceğinizi düşünüyorum

 

[veyselemre]

Sub sorgula()
    Dim con As Object
    Dim rs As Object
    Set con = CreateObject("adodb.connection")
    con.Open "provider=microsoft.jet.oledb.4.0;data source=" & _
             ThisWorkbook.FullName & ";extended properties=""Excel 8.0;hdr=yes"""

    lst = Join(Application.Transpose(Range(Sheets("Hedef").[a3], Sheets("Hedef").Cells(Rows.Count, 1).End(3)).Value), ",")
    
    Sql = "select * from [kaynak$] where [Müşteri No] in (" & lst & ")"

    Set rs = con.Execute(Sql)
    Sheets("Sonuç").[3:65536].ClearContents
    If Not rs.EOF Then Sheets("Sonuç").[a3].CopyFromRecordset rs
    Set rs = Nothing
    Set con = Nothing

End Sub

 

[Orion1]

otofiltre ile süzen alternatif kodlar.
Dosyanız ektedir.

Private Sub CommandButton1_Click()
Dim sonsat As Long, sh As Worksheet
Sheets("Sheet1").Select
sonsat = Cells(Rows.Count, "A").End(xlUp).Row
Set sh = Sheets("Sayfa2")
sh.Range("A:E").ClearContents
Range("A1").AutoFilter
Range("A1").AutoFilter field:=1, Criteria1:=CDbl(TextBox1.Value)
Range("A1").CurrentRegion.Copy sh.Range("A1")
Range("A1").AutoFilter
sh.Shapes(1).Delete
sh.Select
End Sub

 

[andruil]

Merhaba,
performans ne olur bilemem ama
bir deneyiniz.
İyi çalışmalar.

dosyanızda butona bastığımda direkt hata veriyor.

selam,
istediğinizin nerdeyse aynısı olan bir çalışma daha once yapıldı,
hatta bir kaç çözüm önerisi içindende en performanlısı bulundu (onda da kayıt sayısı sizinki gibi fazlaydı)
Sanırım en performanslı çözüm kaynak tabloda kayıtların içinde istenen şartı göre süzme yapmak ve süzülen kayıtları hedef sayfaya yapıştırmak şeklinde olan makroydu

Konu başlığını hatırlayamadım , ama dikkatli bir aramada bulabileceğinizi düşünüyorum

keşke o başlığı bulabilsem, aradım ama bulamadım.

Sub sorgula()
    Dim con As Object
    Dim rs As Object
    Set con = CreateObject("adodb.connection")
    con.Open "provider=microsoft.jet.oledb.4.0;data source=" & _
             ThisWorkbook.FullName & ";extended properties=""Excel 8.0;hdr=yes"""

    lst = Join(Application.Transpose(Range(Sheets("Hedef").[a3], Sheets("Hedef").Cells(Rows.Count, 1).End(3)).Value), ",")
    
    Sql = "select * from [kaynak$] where [Müşteri No] in (" & lst & ")"

    Set rs = con.Execute(Sql)
    Sheets("Sonuç").[3:65536].ClearContents
    If Not rs.EOF Then Sheets("Sonuç").[a3].CopyFromRecordset rs
    Set rs = Nothing
    Set con = Nothing

End Sub

kodu kullandığımda hata veriyor lst= satırında

otofiltre ile süzen alternatif kodlar.
Dosyanız ektedir.

Private Sub CommandButton1_Click()
Dim sonsat As Long, sh As Worksheet
Sheets("Sheet1").Select
sonsat = Cells(Rows.Count, "A").End(xlUp).Row
Set sh = Sheets("Sayfa2")
sh.Range("A:E").ClearContents
Range("A1").AutoFilter
Range("A1").AutoFilter field:=1, Criteria1:=CDbl(TextBox1.Value)
Range("A1").CurrentRegion.Copy sh.Range("A1")
Range("A1").AutoFilter
sh.Shapes(1).Delete
sh.Select
End Sub

bu kod sadece manuel girilen tek müşteriyi sorguluyor ama benim sorgulamam gereken 5000 tane müşteri var



Advanced Filter'ı kullanmayı da denedim ama sanırım satırlar çok fazla olduğu için çalışmıyor.

Destekleriniz için teşekkür ederim ama halen çözüm bulabilmiş değilim ne yazık ki..

 

[Mehmet Şahin]

Merhaba,
hata nedir? ekleyebilir misiniz?

 

[andruil]

Merhaba,
hata nedir? ekleyebilir misiniz?

Compile error:
Can't find project or library

Sub bul()
Dim conn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim s1 As Worksheet
Dim s2 As Worksheet
Dim s3 As Worksheet

Set s1 = ThisWorkbook.Sheets("Kaynak")
Set s2 = ThisWorkbook.Sheets("Hedef")
Set s3 = ThisWorkbook.Sheets("Sonuç")

[B][COLOR="Red"]son1[/COLOR][/B] = s1.[a65536].End(3).Row
son2 = s2.[a65536].End(3).Row
son3 = s3.[a65536].End(3).Row + 1

s3.Range("a2:e" & son3).ClearContents
Set conn = econn
conn.CursorLocation = adUseClient
j = 0
son3 = 2
For q = 3 To son2
     mno = CStr(s2.Cells(q, "a"))
        sqlStr = "select * from [Kaynak$a2:e" & son1 & "]" _
        & " where [F1]='" & mno & "'"


        rs.Open sqlStr, conn, 1, 1
        If rs.EOF = True Then GoTo gec
          s3.Range("a" & son3).CopyFromRecordset rs
          son3 = son3 + rs.RecordCount
        rs.Close
gec:
Set rs = Nothing
 Next q
son:

conn.Close: Set conn = Nothing
Set s1 = Nothing: Set s2 = Nothing: Set s3 = Nothing
End Sub

 

[Mehmet Şahin]

Tools - References sekmesinde Missing yazan yerdeki tiki kaldırıp dener misiniz.
Ve o referansı yazarsanız sevinirim.