• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

FİLTRELEMEYE GÖRE VERİ AKTARMA

U

ufak06

Katılım
16 Temmuz 2018
Mesajlar
19
Excel Vers. ve Dili
Ev ve Öğrenci 2016, Türkçe
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

ZXWMR0.jpg


164V01.jpg


Yardımcı olan arkadaşlara şimdiden çok teşekkür ederim.
 
Aşağıdaki kodları bir modüle kopyalayıp deneyiniz:

SQL: 
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
 
Yusuf boş olmayan verileri getirmek için sorguda is null 'u kullanabilirsiniz.

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

Kod: 
sorgu = "select [Cari Kodu],[Ticari Unvanı],[İli],[Fatura Tarihi],[Fatura No],[Genel Toplam]" & _
  "from[Sayfa1$] where [Cari Kodu] is not null  "
 
Teşekkürler Sayın Erdem. Sayenizde bulaştık bakalım sql'e :)
 
Sayın Erdem'in gösterdiği yol üzere kodun son hali aşağıdaki gibidir:

PHP: 
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:

PHP: 
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:

PHP: 
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
 
YUSUF44' Alıntı:
Sayın Erdem'in gösterdiği yol üzere kodun son hali aşağıdaki gibidir:

PHP: 
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:

PHP: 
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:

PHP: 
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
Genişletmek için tıkla ...

Kardeşim harikasın eline sağlık...
 
YUSUF44' Alıntı:
Sayın Erdem'in gösterdiği yol üzere kodun son hali aşağıdaki gibidir:

PHP: 
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:

PHP: 
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:

PHP: 
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
Genişletmek için tıkla ...
Bu kodu nasıl çalıştıracağım kardeşim ona da bi değinir misin?
 
ufak06' Alıntı:
Bu kodu nasıl çalıştıracağım kardeşim ona da bi değinir misin?
Genişletmek için tıkla ...
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' Alıntı:
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.
Genişletmek için tıkla ...
@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
 
Ç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?
 
@YUSUF44 Harikasınız dememin sebebi cevap verildiği içindi deneme şansını biraz önce buldum.
 
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.
 
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 ?
 
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ı :)
 
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) & "' "
 
NextLevel' Alıntı:
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) & "' "
Genişletmek için tıkla ...

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
 
Worksheet Change olayında kodu çalıştırabilirsiniz

Forumda Intersect diye aratırsan çabucak örnekler bulabilirsiniz.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst