veri aktarma kodunda sorun

[m.gur]

Merhaba
Aşağıdaki kodları sayın Evren Gizlen bey yazmıştı bana. O dosyayı kullanıyorum. Ancak bu kodları bu dosyaya uyarlamaya çalıştım fakat SQL den pek anlamadığım için yapamadım. Yinede birşeyler yapabildim. Sayfa1 den sayfa 2 ye ancak 1 satır aktarabildim. Yapmak istediğimi açıklayayım. Sayfa1 den verilerin bazılarını sayfa2 ye almak istiyorum bunu yaparken de sıralama yapmasını istiyorum. Sayfa1 in "K" sütunundaki veriler küçükten büyüğe doğru sayfa2 nin "F" sütununa aktarılsın.
Sub AKTAR_SONUC_MOT()
Dim conn As Object, rs As Object
Sheets("sayfa2").Unprotect
Sheets("sayfa2").Range("A3:K65536").ClearContents
Set conn = CreateObject("AdoDb.Connection")
Set rs = CreateObject("AdoDb.Recordset")
conn.Open ("provider=microsoft.jet.oledb.4.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""excel 8.0;Hdr=no;imex=1"";")
rs.Open ("Select first(F4),first(F5),first(F9),first(F11),first(F15),first(F10)from [sayfa1$A3:O65536] where not (F4)is null group by (F1)"), conn, 1, 3
If rs.RecordCount > 0 Then
Application.ScreenUpdating = False
Sheets("sayfa2").Range("c3").CopyFromRecordset rs
Sheets("sayfa2").Select
Application.ScreenUpdating = True
MsgBox "Aktarım tamamlandı"
Sheets("sayfa2").Protect
End If
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing

End Sub

Dosyayı da ekliyorum. Teşekkürler.

 

[halit3]

Alternatif kod

Sub aktar()
Sheets("Sayfa2").Range("B3:H65000").ClearContents
sat = 3
For r = 3 To Worksheets("Sayfa1").Cells(Rows.Count, "d").End(3).Row
If Sheets("Sayfa1").Cells(r, "d").Value <> "" Then
Sheets("Sayfa2").Cells(sat, "b").Value = Sheets("Sayfa1").Cells(r, "f").Value
Sheets("Sayfa2").Cells(sat, "c").Value = Sheets("Sayfa1").Cells(r, "d").Value
Sheets("Sayfa2").Cells(sat, "d").Value = Sheets("Sayfa1").Cells(r, "e").Value
Sheets("Sayfa2").Cells(sat, "e").Value = Sheets("Sayfa1").Cells(r, "ı").Value
Sheets("Sayfa2").Cells(sat, "f").Value = Sheets("Sayfa1").Cells(r, "k").Value
Sheets("Sayfa2").Cells(sat, "g").Value = Sheets("Sayfa1").Cells(r, "o").Value
Sheets("Sayfa2").Cells(sat, "h").Value = Sheets("Sayfa1").Cells(r, "j").Value
sat = sat + 1
End If
Next r
Sheets("Sayfa2").Range("B3:H65000").Sort Key1:=Sheets("Sayfa2").Range("F3"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
MsgBox "İŞLEM TAMAM"

End Sub

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Sub AKTAR_SONUC_MOT()
    Dim conn As Object, rs As Object
    Sheets("sayfa2").Unprotect
    Sheets("sayfa2").Range("A3:K65536").ClearContents
    Set conn = CreateObject("AdoDb.Connection")
    Set rs = CreateObject("AdoDb.Recordset")
    conn.Open ("provider=microsoft.jet.oledb.4.0;data source=" & _
    ThisWorkbook.FullName & ";extended properties=""excel 8.0;Hdr=no;imex=1"";")
    rs.Open ("Select first(F4),first(F5),first(F9),first(F11),first(F15),first(F10) from [sayfa1$A3:O65536] where not (F4) is null group by (F4) Order By first(F11) Asc"), conn, 1, 3
 
    If rs.RecordCount > 0 Then
        Application.ScreenUpdating = False
        Sheets("sayfa2").Range("c3").CopyFromRecordset rs
        Sheets("sayfa2").Select
        Application.ScreenUpdating = True
        MsgBox "Aktarım tamamlandı"
        Sheets("sayfa2").Protect
    End If
 
    rs.Close
    conn.Close
    Set rs = Nothing
    Set conn = Nothing
End Sub

 

[m.gur]

Sayın Halit bey ilginiz için teşekkür ederim. Kodlar çalışıyor, sorun yok. Affınıza sığınarak şunu söylemek istiyorum veriler çok olunca bu tip kodlar yavaş çalışıyor. SQL çok hızlı çalışıyor ve ben bunu öğrenmeye daha doğrusu anlamaya çalışıyorum. Bazı yerleri çözdüm ama nereye ne yazarsam istediğimi elde edebilirim onu anlıyamadım. Bu kodlar üzerinde değişiklik yapmakla çözemezmiyiz acaba. Her iki kodu da ekleyip dosyamı güncelledim.

 

[m.gur]

Sayın Korhan Ayhan mesajınızı son anda gördüm. Kodları denedim ancak şöyle bir şey var. O kodlar sayfa1 deki verileri parça nosuna göre karşılaştırıp aynı olanları toplayıp aktarıyor. Benim istediğim aynı no.dan kaç adet olursa olsun hepsini aktarsın. Sayfa1 deki veriler arasındaki boşluğu özellikle yaptım çünkü bazı verilerin aralarında boş satırlar olmak zorunda.

 

[Korhan Ayhan]

Selamlar,

Sn. m.ugur,

Siz ilk mesajınızda sadece sıralama kodu istemiştiniz. Şimdi ise aktarım işlemi hatalı diyorsunuz. Ben aktarılma ilgili bir değişiklik yapmadım. Sadece kodunuza sıralama eklentisi yaptım. Örnek dosyanıza göre olması gereken tablonuzu Sayfa2 'ye ekleyip dosyanızı güncellermisiniz.

 

[m.gur]

Dosya güncellendi.

 

[Korhan Ayhan]

Selamlar,

Sorgu satırınızı aşağıdaki şekilde değiştirip denermisiniz.

rs.Open ("Select (F4),(F5),(F9),(F11),(F15),(F10) From [sayfa1$A3:O65536] Where Not (F4) is null Order By (F11) "), conn, 1, 3

 

[m.gur]

Sayın Korhan Ayhan çok teşekkür ederim, çok güzel oldu şimdi gayet güzel çalışıyor. Merak ettiğim için soruyorum ben daha önce sorgudan "group by" kelimesini çıkarmıştım toplamayı onun yaptığını bir yerden okudum fakat yine olmamıştı. First kelimesininde sütundaki ilk değer olduğunu öğrendim onun yerine de değişik şeyler yazıp denedim tabi yine olmamıştı. Şimdiki sorguda sadece sütun isimleri var first kelimesi yok. Biraz açıklıyabilirmisiniz vaktiniz olduğunda. Kodların diğer kısımlarını hemen hemen iyice kavradım. Teşekkür ederim. İyi geceler.