filtreleyip sayfalara ayırma

VBA Makrolar ile ilgili sormak istedikleriniz, yapmak istedikleriniz hakkında yardım alabileceğiniz bölümdür.

filtreleyip sayfalara ayırma

İleti#1)  rastbin » 19 Eyl 2018 16:16

Merhaba,

excel tablodam a dan d ya kadar olan bilgiler mevcut.d sütununda isimler yazıyor.isimlere göre filtreleyip masa üstüne ayrı excel olarak nasıl kayıt edebilirim.yani ismi tarkan olan tüm verileri alıp bir excele kopyalamak.o excelide masaüstüne yapıştırmak.

ayrıca isimlerin bulunduğu sütun değişiklik gösterebilir.

teşekkürler.
Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
Kullanıcı avatarı
rastbin
Yeni Başlamış
 
Kayıt: 13 Ağu 2018 10:31
Meslek: Bilgi Teknolojileri Uzmanı
Yaş: 25
İleti: 56
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: İstanbul

Cevap: filtreleyip sayfalara ayırma

İleti#2)  metehan8001 » 20 Eyl 2018 00:49

rastbin yazdı:Merhaba,

excel tablodam a dan d ya kadar olan bilgiler mevcut.d sütununda isimler yazıyor.isimlere göre filtreleyip masa üstüne ayrı excel olarak nasıl kayıt edebilirim.yani ismi tarkan olan tüm verileri alıp bir excele kopyalamak.o excelide masaüstüne yapıştırmak.

ayrıca isimlerin bulunduğu sütun değişiklik gösterebilir.

teşekkürler.


Buyrun dosyanız ektedir. Filtreleme ile değil de ADO ile döngü kurarak yapılmıştır. İsimlerin bulunduğu sütün değişiklik gösterirse sütün başlığı "isimler" olması zorunda.
Kod: Tümünü seç
Sub ExcelDepo()
'www.exceldepo.com metehan8001@gmail.com
Set con = CreateObject("Adodb.Connection")
Set rs = CreateObject("Adodb.Recordset")
sayfa = "Sayfa1" ' sayfa adını buraya yaz.
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""
sorgu = "select distinct (isimler) from [" & sayfa & "$a1:d65536]"
rs.Open sorgu, con, 1, 1
If rs.RecordCount > 0 Then
            Do While Not rs.EOF
            adi = rs(0).Value
'isimlere göre sayfa oluştur
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = adi
Set bag = CreateObject("Adodb.Connection")
bag.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""
                    Set kayit = CreateObject("Adodb.Recordset")
                    s = "select * from [" & sayfa & "$a1:d65536] where (isimler) = '" & adi & "'"
                    kayit.Open s, bag, 1, 1
On Error Resume Next
For i = 0 To kayit.Fields.Count 'SUTUN BAŞLIKLARI İÇİN
Cells(1, i + 1).Value = kayit.Fields(i).Name 'SUTUN BAŞLIKLARI İÇİN
Next i 'SUTUN BAŞLIKLARI İÇİN
On Error GoTo 0
                    If kayit.RecordCount > 0 Then
                    Range("a2").CopyFromRecordset kayit
                    End If
                    kayit.Close: bag.Close
           'OLUŞTURULAN DOSYAYI MASAUSTUNE KAYDET
          On Error Resume Next
          Set WS = CreateObject("WScript.Shell")
          desk = WS.SpecialFolders("Desktop")
          Sheets(adi).Copy
          Sheets(adi).SaveAs desk & "\" & adi & ".xlsx"
          ActiveWorkbook.Close
          Application.DisplayAlerts = False
          Sheets(adi).Delete
          Application.DisplayAlerts = True
          On Error GoTo 0
             'OLUŞTURULAN DOSYAYI MASAUSTUNE KAYDET
             say = say + 1
            rs.movenext
            Loop
End If
MsgBox "İşlem tamam " & say & " adet dosya masaüstüne kaydedildi", vbInformation + vbMsgBoxRtlReading, "Www.ExcelDepo.Com"
rs.Close: con.Close
Set rs = Nothing: Set con = Nothing
End Sub

Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
Kullanıcı avatarı
metehan8001
Siteye Alışmış
 
Adı Soyadı:mete han
Kayıt: 18 Ekm 2011 10:30
İleti: 393
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: OSMANİYE


Forum Genel Makro Soruları

Online Kullanıcılar

Bu forumu görüntüleyenler: Bing[Bot], Google [Bot] ve 2 misafir

Bumerang - Yazarkafe