[rastbin]

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.

[metehan8001]

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