FİLTRELEMEYE GÖRE VERİ AKTARMA

[ufak06]

Merhaba Arkadaşlar, değerli forum üyeler, ve yöneticileri;
Ekte bulunan Exccel Dosyasında A sütununda içerisinde CR bulunan numaralar mevcut. Ben 2. sayfada bir filtreleme yapmak istiyorum bu filtreleme şu işlev olacak;

1. Sayfada A Sütununda CR bulunan tüm kayıtları 2. Sayfaya aktar, bu aktarmayı yaparken aktarılan satırın karşılığı olan B, C, D, E, F, sütunlarını da aktar.
Dosya Linki: http://s7.dosya.tc/server11/3clyfh/Yeni_Microsoft_Excel_Calisma_Sayfasi.xlsx.html

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

 

[YUSUF44]

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz:

Sub suz()
Set con = VBA.CreateObject("adodb.Connection")

con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""

sorgu = "select [Cari Kodu],[Ticari Unvanı],[İli],[Fatura Tarihi],[Fatura No],[Genel Toplam]" & _
  "from[Sayfa1$] where [Cari Kodu] > '" & "" & "'  "

Set rs = con.Execute(sorgu)
Sheets("Sayfa3").Range("A2").CopyFromRecordset rs

End Sub

 

[turist]

Sayın @ufak06
Dosyanızın Linki
indirip inceleyiniz.

 

[Erdem Akdemir]

Yusuf boş olmayan verileri getirmek için sorguda is null 'u kullanabilirsiniz.

İs null boş olanları, is not null boş olmayanları getirir.

sorgu = "select [Cari Kodu],[Ticari Unvanı],[İli],[Fatura Tarihi],[Fatura No],[Genel Toplam]" & _
  "from[Sayfa1$] where [Cari Kodu] is not null  "

 

[YUSUF44]

Teşekkürler Sayın Erdem. Sayenizde bulaştık bakalım sql'e

 

[YUSUF44]

Sayın Erdem'in gösterdiği yol üzere kodun son hali aşağıdaki gibidir:

Sub suz()
Set con = VBA.CreateObject("adodb.Connection")

con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""

sorgu = "select [Cari Kodu],[Ticari Unvanı],[İli],[Fatura Tarihi],[Fatura No],[Genel Toplam]" & _
  "from[Sayfa1$] where [Cari Kodu] is not null  "
 
Set rs = con.Execute(sorgu)
Sheets("Sayfa3").Range("A2").CopyFromRecordset rs

End Sub

Eğer verilerin Sayfa3'teki ilk boş satıra aktarılmasını istiyorsanız aşağıdaki gibi kullanabilirsiniz:

Sub suz()
yeni = Sheets("Sayfa3").Cells(Rows.Count, "A").End(3).Row + 1

Set con = VBA.CreateObject("adodb.Connection")

con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""

sorgu = "select [Cari Kodu],[Ticari Unvanı],[İli],[Fatura Tarihi],[Fatura No],[Genel Toplam]" & _
  "from[Sayfa1$] where [Cari Kodu] is not null  "
 
Set rs = con.Execute(sorgu)
Sheets("Sayfa3").Range("A" & yeni).CopyFromRecordset rs

End Sub

Eğer Sayfa3'teki eski verilerin silinip yerine yeni verilerin aktarılmasını istiyorsanız ise aşağıdaki şekilde kullanabilirsiniz:

Sub suz1()
eski = WorksheetFunction.Max(2, Sheets("Sayfa3").Cells(Rows.Count, "A").End(3).Row)
Sheets("Sayfa3").Range("A2:F" & eski).ClearContents
Set con = VBA.CreateObject("adodb.Connection")

con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""

sorgu = "select [Cari Kodu],[Ticari Unvanı],[İli],[Fatura Tarihi],[Fatura No],[Genel Toplam]" & _
  "from[Sayfa1$] where [Cari Kodu] is not null  "
 
Set rs = con.Execute(sorgu)
Sheets("Sayfa3").Range("A2").CopyFromRecordset rs

End Sub

 

[ufak06]

Sayın Erdem'in gösterdiği yol üzere kodun son hali aşağıdaki gibidir:

Sub suz()
Set con = VBA.CreateObject("adodb.Connection")

con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""

sorgu = "select [Cari Kodu],[Ticari Unvanı],[İli],[Fatura Tarihi],[Fatura No],[Genel Toplam]" & _
  "from[Sayfa1$] where [Cari Kodu] is not null  "

Set rs = con.Execute(sorgu)
Sheets("Sayfa3").Range("A2").CopyFromRecordset rs

End Sub

Eğer verilerin Sayfa3'teki ilk boş satıra aktarılmasını istiyorsanız aşağıdaki gibi kullanabilirsiniz:

Sub suz()
yeni = Sheets("Sayfa3").Cells(Rows.Count, "A").End(3).Row + 1

Set con = VBA.CreateObject("adodb.Connection")

con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""

sorgu = "select [Cari Kodu],[Ticari Unvanı],[İli],[Fatura Tarihi],[Fatura No],[Genel Toplam]" & _
  "from[Sayfa1$] where [Cari Kodu] is not null  "

Set rs = con.Execute(sorgu)
Sheets("Sayfa3").Range("A" & yeni).CopyFromRecordset rs

End Sub

Eğer Sayfa3'teki eski verilerin silinip yerine yeni verilerin aktarılmasını istiyorsanız ise aşağıdaki şekilde kullanabilirsiniz:

Sub suz1()
eski = WorksheetFunction.Max(2, Sheets("Sayfa3").Cells(Rows.Count, "A").End(3).Row)
Sheets("Sayfa3").Range("A2:F" & eski).ClearContents
Set con = VBA.CreateObject("adodb.Connection")

con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""

sorgu = "select [Cari Kodu],[Ticari Unvanı],[İli],[Fatura Tarihi],[Fatura No],[Genel Toplam]" & _
  "from[Sayfa1$] where [Cari Kodu] is not null  "

Set rs = con.Execute(sorgu)
Sheets("Sayfa3").Range("A2").CopyFromRecordset rs

End Sub

Kardeşim harikasın eline sağlık...

 

[ufak06]

Sayın Erdem'in gösterdiği yol üzere kodun son hali aşağıdaki gibidir:

Sub suz()
Set con = VBA.CreateObject("adodb.Connection")

con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""

sorgu = "select [Cari Kodu],[Ticari Unvanı],[İli],[Fatura Tarihi],[Fatura No],[Genel Toplam]" & _
  "from[Sayfa1$] where [Cari Kodu] is not null  "

Set rs = con.Execute(sorgu)
Sheets("Sayfa3").Range("A2").CopyFromRecordset rs

End Sub

Eğer verilerin Sayfa3'teki ilk boş satıra aktarılmasını istiyorsanız aşağıdaki gibi kullanabilirsiniz:

Sub suz()
yeni = Sheets("Sayfa3").Cells(Rows.Count, "A").End(3).Row + 1

Set con = VBA.CreateObject("adodb.Connection")

con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""

sorgu = "select [Cari Kodu],[Ticari Unvanı],[İli],[Fatura Tarihi],[Fatura No],[Genel Toplam]" & _
  "from[Sayfa1$] where [Cari Kodu] is not null  "

Set rs = con.Execute(sorgu)
Sheets("Sayfa3").Range("A" & yeni).CopyFromRecordset rs

End Sub

Eğer Sayfa3'teki eski verilerin silinip yerine yeni verilerin aktarılmasını istiyorsanız ise aşağıdaki şekilde kullanabilirsiniz:

Sub suz1()
eski = WorksheetFunction.Max(2, Sheets("Sayfa3").Cells(Rows.Count, "A").End(3).Row)
Sheets("Sayfa3").Range("A2:F" & eski).ClearContents
Set con = VBA.CreateObject("adodb.Connection")

con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""

sorgu = "select [Cari Kodu],[Ticari Unvanı],[İli],[Fatura Tarihi],[Fatura No],[Genel Toplam]" & _
  "from[Sayfa1$] where [Cari Kodu] is not null  "

Set rs = con.Execute(sorgu)
Sheets("Sayfa3").Range("A2").CopyFromRecordset rs

End Sub

Bu kodu nasıl çalıştıracağım kardeşim ona da bi değinir misin?

 

[ufak06]

Sayın @ufak06
Dosyanızın Linki
indirip inceleyiniz.

Burada ki dosyada sol kısıma sütun eklediğimde orayı baz alarak aktarma yapıyor onu nasıl belirleriz?

 

[YUSUF44]

Bu kodu nasıl çalıştıracağım kardeşim ona da bi değinir misin?

bu kodları kopyalayın, excel dosyanızdayken Alt+F11 yaparak VBA penceresini açın
Açılan sayfada Insert menüsünden Module'yi seçin
Açılan sayfaya kodları yapıştırın
Excel dosyasına geçin
Sayfaya bir adet düğme/nesne/resim vs ekleyin
Eklenen nesneye sağ tıklayıp makro ata deyin
Açılan ekranda ilgili makroyu seçin
Artık o nesneye her bastığınızda makro çalışacaktır

Dosyayı kaydederken makro içerebilen excel dosyası olarak kaydetmelisiniz.

 

[ufak06]

bu kodları kopyalayın, excel dosyanızdayken Alt+F11 yaparak VBA penceresini açın
Açılan sayfada Insert menüsünden Module'yi seçin
Açılan sayfaya kodları yapıştırın
Excel dosyasına geçin
Sayfaya bir adet düğme/nesne/resim vs ekleyin
Eklenen nesneye sağ tıklayıp makro ata deyin
Açılan ekranda ilgili makroyu seçin
Artık o nesneye her bastığınızda makro çalışacaktır

Dosyayı kaydederken makro içerebilen excel dosyası olarak kaydetmelisiniz.

@YUSUF44 kardeşim dediklerini yaptım Butona basıp Makro Ata dediğimde "Başvuru bir makro sayfasına yönelik olmalıdır." hatası alıyorum

 

[YUSUF44]

Çalıştıramıyorsanız yukarda neden "Kardeşim harıkasın" dediniz? Çalıştırmadan mı dediniz yoksa başka bir sıkıntı mı var?

 

[ufak06]

@YUSUF44 Harikasınız dememin sebebi cevap verildiği içindi deneme şansını biraz önce buldum.

 

[YUSUF44]

Bir şeyleri yanlış yapıyorsunuz demek ki. Baştan ve sırasıyla yapar mısınız? Eskiden eklediğiniz makroyu da iptal edin.

 

[kiran67]

Sa konu eski ama ben de buna benzer birşey arıyordum. Ben Bütün verilerin gelmesini istemiyorum. Örneğin Sayfa 3 de bir yerde Cari kod yazsın Cari kodu o olanlar gelsin gibi birşey yapılabilir mi ?

 

[kiran67]

sorgu = "select [Cari Kodu],[Ticari Unvanı],[İli],[Fatura Tarihi],[Fatura No],[Genel Toplam]" & _
"from[Sayfa1$] where [Cari Kodu]=Sheets(Sayfa3).Range (H1) " bu şekilde değiştirdim olmadı

 

[ÖmerFaruk]

sorgu = "select [Cari Kodu], [Ticari Unvanı], [İli], [Fatura Tarihi], [Fatura No], [Genel Toplam] from[Sayfa1$] Where [Cari Kodu]= " & Sheets(Sayfa3).Range (H1)

olmaz ise
sorgu = "select [Cari Kodu], [Ticari Unvanı], [İli], [Fatura Tarihi], [Fatura No], [Genel Toplam] from[Sayfa1$] Where [Cari Kodu]= '" & Sheets(Sayfa3).Range (H1) & "' "

 

[kiran67]

sorgu = "select [Cari Kodu], [Ticari Unvanı], [İli], [Fatura Tarihi], [Fatura No], [Genel Toplam] from[Sayfa1$] Where [Cari Kodu]= " & Sheets(Sayfa3).Range (H1)

olmaz ise
sorgu = "select [Cari Kodu], [Ticari Unvanı], [İli], [Fatura Tarihi], [Fatura No], [Genel Toplam] from[Sayfa1$] Where [Cari Kodu]= '" & Sheets(Sayfa3).Range (H1) & "' "

Teşekkür ederim ilk baştaki çalıştı kendi excelime uyarladım. Güzel çalışıyor. Peki bu kod değiştiğinde makro çalıştır yerine otomatik olarak getirme olabilir mi. Range("U2") de kütük no var. Orası değiştiğinde otomatik olarak verileri getirip yazma imkanı varmı?

Sub suz1()

eski = WorksheetFunction.Max(2, Sheets("KÜTÜK FİŞİ").Cells(Rows.Count, "A").End(3).Row)
Sheets("KÜTÜK FİŞİ").Range("A17:K30" & eski).ClearContents
Set con = VBA.CreateObject("adodb.Connection")

con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""


sorgu = "select [ESKİ İŞYERİ],[UNVANI1],[YENİ İŞYERİ],[UNVANI2],[BASLAMA TARİHİ]" & _
"from[UNVAN DEGİSİM$] where [KÜTÜK NO]= " & Sheets("KÜTÜK FİŞİ").Range("U2")

Set rs = con.Execute(sorgu)
Sheets("KÜTÜK FİŞİ").Range("A17").CopyFromRecordset rs

End Sub

 

[ÖmerFaruk]

Worksheet Change olayında kodu çalıştırabilirsiniz

Forumda Intersect diye aratırsan çabucak örnekler bulabilirsiniz.