• DİKKAT

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

Hücrelere göre sayfalar açıp verileri listele

lovecaroline

lovecaroline

Altın Üye
Katılım
21 Mayıs 2014
Mesajlar
78
Excel Vers. ve Dili
2013 (64 Bit)
2010 (64 bit)
Merhaba,
Dönem sütununda (F) yer alan isimlere göre sayfalar açılsın ve açılan sayfalara o dönemlere ait veriler “DATA” sayfasındaki gibi listelensin istiyorum.
Data sayfasındaki listenin sonu belli değil. Sınırsız satır olabilir. Değişebilir.
Yardımcı olabilecek arkadaşlara çok teşekkür ederim.
 

Ekli dosyalar

Bu linkte benzer konular işlenmiş..

Veri Aktarma Butonu

Arkadaşlar bir listem var. Kategorilerin olduğu sutunda A - B - C kategorileri var. Buton yardımı ile A kategorisindeki bilgileri A KATEGORİSİ sayfasını aktarmasını istiyorum ve yardılarınızı bekliyorum iyi çalışmalar.
www.excel.web.tr www.excel.web.tr
 
Korhan Ayhan' Alıntı:
Bu linkte benzer konular işlenmiş..

Veri Aktarma Butonu

Arkadaşlar bir listem var. Kategorilerin olduğu sutunda A - B - C kategorileri var. Buton yardımı ile A kategorisindeki bilgileri A KATEGORİSİ sayfasını aktarmasını istiyorum ve yardılarınızı bekliyorum iyi çalışmalar.
www.excel.web.tr www.excel.web.tr
Genişletmek için tıkla ...
İlginiz için teşekkür ederim ama maalesef gönderdiğiniz link ihtiyacımı karşılamadı Korhan Bey.

Basit kullanımlı bir makro olsa; hangi sütundaki verilere göre sayfalama yapılmasını kolaylıkla seçebileceğim. Çünkü şu an dönem (F) sütununu referans almam gerekiyor ama bu değişebiliyor çoğu zaman.

Eğer bu şekilde yardımcı olabileceğiniz bir kod olursa çok mutlu olurum. Tekrardan çok teşekkür ederim.
 
Necdet' Alıntı:
Merhaba

Linki İnceleyiniz. 4 nolu mesaj.
Genişletmek için tıkla ...
Öncelikle teşekkür ederim ilginiz için.
Söz konusu kodlarla örnek dosya üzerinden F sütunu için dener misiniz lütfen. Sistem çok güzel düşünülmüş ama tüm verileri hepsi için aktarıyor. İstediğim sadece aynı isimdeki verileri satır olarak ilgili yere kaydetsin şeklinde. Ayrıca hücre içinde 2017/2 gibi bir değer varsa çok farklı bir şey ortaya koyuyor.
Benim fark etmeden yanlış yaptığım bir şey de olabilir.
Anlattığım durumla ilgili yardımcı olabilir misiniz.
 

Ekli dosyalar

sayfa isminde / olmaması gerek, onları toptan değiştirin öyle deneyin.
 
Necdet' Alıntı:
sayfa isminde / olmaması gerek, onları toptan değiştirin öyle deneyin.
Genişletmek için tıkla ...
"/"ları kaldırdım ama anlamadığım bir nedenle F sütunu için çalışmıyor. Ben ilkine 1 yazıyorum, ikinci yere başlık hücresini veya tüm sütunu ve verilerin olduğu kadar sütunu veya F sütunundaki herhangi bir hücreyi seçerek denedim. Ama her defasında; sayfaları açıyor ama sayfalara tüm verileri kopyalıyor.
Kontrol eder misiniz ve hatam varsa yönlendirme yapabilir misiniz lütfen. Şimdiden teşekkürler.
 

Ekli dosyalar

Merhaba,

Aşağıdaki kodları dener misiniz?

Kod: 
Sub Ornek2()

    Dim coll As New Collection
    Dim i   As Integer
    Dim sec As Range
    Dim rng As Range
    Dim syf As String
    Dim ash As Worksheet
   
    Set ash = Sheets("DATA")
    If ash.AutoFilterMode = False Then Range("A1").CurrentRegion.AutoFilter
   
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With
   
    Set rng = Range("A1").CurrentRegion
   
    On Error Resume Next

    Set sec = Application.InputBox("Sayfalara Ayıracağınız Sütundan Bir Hücre Seçiniz", "SÜTUN BELİRLEME", Range("F1").Address, Type:=8)
    On Error GoTo 0
    If sec Is Nothing Then End
   
    On Error Resume Next
    For i = 2 To Cells(Rows.Count, "A").End(3).Row
        coll.Add Cells(i, sec.Column).Value, Cells(i, sec.Column).Value & " "
    Next i
    On Error GoTo 0
   
    For i = 1 To coll.Count
        syf = Replace(coll(i), "/", "_")
        If SheetExists(syf) = False Then
            Sheets.Add after:=Sheets(Sheets.Count)
            ActiveSheet.Name = syf
        Else
            Sheets(syf).Cells.ClearContents
        End If
       
        rng.AutoFilter Field:=sec.Column, Criteria1:=coll(i)
        rng.SpecialCells(xlCellTypeVisible).Copy Sheets(syf).Range("A1")
        Cells.EntireColumn.AutoFit
        ash.ShowAllData

    Next i

    ash.Select
    rng.AutoFilter
   
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With
   
End Sub

Kod: 
Function SheetExists(shName As String) As Boolean
    On Error Resume Next
    SheetExists = CBool(Len(Worksheets(shName).Name) > 0)
End Function
 

Ekli dosyalar

Son düzenleme:
Bir deneme de ADO ile yaptım.
Ne yaptıysam Dönem değerinde 2016_1, 2016-1 gibi verilerde tür uyuşmazlığı hatası aldım.
Tireli, alt çizgili olmazsa çalışıyor gibi.
Kod: 
Sub ADOB_ORNEK()

    'Referanslardan Microsoft ActiveX Data Objects 6.0 (en büyük değer) Library seçili olmalı
    Dim connection As New ADODB.connection
    Dim DosyaAdı As String
    Dim query As String
    Dim rs As New ADODB.Recordset
    Dim arr As Variant
    Dim coll As New Collection
    Dim i   As Integer
    Dim sec As Range
    Dim syf As String
    Dim aSh As Worksheet
    Dim srg As String
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With
    
    Set aSh = Sheets("DATA")
    
    arr = aSh.Range("A1").CurrentRegion.Value
      
    On Error Resume Next

    Set sec = Application.InputBox("Sayfalara Ayıracağınız Sütundan Bir Hücre Seçiniz", "SÜTUN BELİRLEME", Range("F1").Address, Type:=8)
    On Error GoTo 0
    If sec Is Nothing Then End
    
    
    On Error Resume Next
    For i = 2 To UBound(arr, 1)
        coll.Add arr(i, sec.Column), arr(i, sec.Column) & " "
    Next i
    On Error GoTo 0
    
    DosyaAdı = ThisWorkbook.FullName
    
    connection.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DosyaAdı & _
                ";Extended Properties=""Excel 12.0;HDR=Yes;"";"
                
    For i = 1 To coll.Count
        syf = coll(i)
        If SayfaVarYok(syf) = False Then
            Sheets.Add after:=Sheets(Sheets.Count)
            ActiveSheet.Name = syf
            aSh.Select
        Else
            Sheets(syf).Cells.ClearContents
        End If
        If IsNumeric(coll(i)) = False Then
            srg = "'" & coll(i) & "'"
        Else
            srg = coll(i)
        End If
            
        query = "SELECT * FROM [" & aSh.Name & "$] WHERE [" & arr(1, sec.Column) & "] = " & srg & " "
        
        rs.Open query, connection
            
        Sheets(syf).Range("A1").Resize(1, UBound(arr, 2)) = arr
        Sheets(syf).Range("A2").CopyFromRecordset rs
        Sheets(syf).Cells.EntireColumn.AutoFit
        rs.Close
        
    Next i
    
    connection.Close
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With
    
    MsgBox coll.Count & " ADET SAYFA AÇILDI VE AKTARILDI...."
    
End Sub

Function SayfaVarYok(shAd As String) As Boolean

On Error Resume Next
SayfaVarYok = Len(Sheets(shAd).Name) > 0

End Function
 

Ekli dosyalar

Son yazdığınız kodlar aşağıdaki gibi akıcı ve işlevsel olmadı benim açımdan. Çünkü aşağıdakinde hem sütünü mouse ile seçebiliyorsun, hem çoklu seçenekler var. Sistem güzel düşünülmüş, kolay ve kullanışlı. Sadece son sütunda işlem yapmıyor. Eğer onu düzeltebilirsek harika bir çalışma olur. Üstte yaptığınız çalışmalarda güzel fakat kodu başka bir dosyaya kopyaladığımda adoyu arıyor. (belki ben bilemiyorum kullanmayı) ayrıca diğer seçenekler de yok. Size zahmet veriyorum biliyorum ama umarım anlayışla karşılarsınız.
Kod: 
Son yazdığınız kodlar aşağıdaki gibi akıcı ve işlevsel olmadı benim açımdan. Çünkü aşağıdakinde hem sütünü mouse ile seçebiliyorsun, hem çoklu seçenekler var. Sistem güzel düşünülmüş, kolay ve kullanışlı. Sadece son sütunda işlem yapmıyor. Eğer onu düzeltebilirsek harika bir çalışma olur. Üstte yaptığınız çalışmalarda güzel fakat kodu başka bir dosyaya kopyaladığımda adoyu arıyor. (belki ben bilemiyorum kullanmayı) ayrıca diğer seçenekler de yok. Size zahmet veriyorum biliyorum ama umarım anlayışla karşılarsınız.

Sub Dosyalara_Sayfalara_Ayır()
Sub Dosyalara_Sayfalara_Ayır()

'Necdet www.excel.web.tr

    Dim i           As Long, _
        SSat        As Long, _
        Sat         As Long, _
        SKol        As Integer, _
        BKol        As Integer, _
        DosyaSayfa  As Integer, _
        Secim       As Range, _
        rngAlan     As Range, _
        Liste()     As String, _
        Yol         As String, _
        DosyaAd     As String, _
        DosyaUz     As String, _
        DosyaSy     As String, _
        Surum       As String, _
        Mes         As String, _
        ws          As Worksheet, _
        wsNew       As Worksheet
        
    Surum = ActiveWorkbook.FileFormat
    Set ws = Sheets(ActiveSheet.Name)
    
    On Error Resume Next
Basla:
    DosyaSayfa = Application.InputBox("1. SAYFALARA AYIRMA, 2. DOSYALARA AYIRMA, 3. YAZDIR", "YÖNTEM SEÇİMİ.....", 1, Type:=1)
    If DosyaSayfa = 0 Then Exit Sub
    If DosyaSayfa > 3 Then GoTo Basla
    
    Yol = ActiveWorkbook.Path & Application.PathSeparator
    DosyaUz = ".xlsx"
    If DosyaSayfa = 2 Then DosyaSy = InputBox("Dosya Adı Ne Olarak Başlasın", "Dosya Adı Girişi")
        
    On Error Resume Next
    Application.DisplayAlerts = False
    
    Set Secim = Application.InputBox("Sütunu seçmek için bir hücre(ler) Seçiniz", "N. YEŞERTENER --> Sütun Belirleme", Type:=8)
    If Secim Is Nothing Then Exit Sub
    
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    
    Sat = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    SKol = Cells.Find("*", , , , xlByColumns, xlPrevious).Column + 1
    BKol = Secim.Column
    
    Set rngAlan = Range(Cells(1, 1), Cells(Sat, SKol - 1))
    
    Columns(BKol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Cells(1, SKol), Unique:=True
    SSat = Cells(Rows.Count, SKol).End(3).Row
    
    ReDim Liste(SSat - 2)
    
    For i = 2 To SSat
        Liste(i - 2) = Cells(i, SKol)
    Next i
    
    Columns(SKol).Clear
    SSat = Cells(Rows.Count, "A").End(3).Row
    SKol = SKol - 1
    
    Selection.AutoFilter
    
    If DosyaSayfa = 1 Then
        Sheets(Liste).Delete
        For i = 0 To UBound(Liste)
            Sheets.Add After:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = Liste(i)
        Next i
        ws.Select
    End If
    
    For i = 0 To UBound(Liste)
        ActiveSheet.Range(Cells(1, 1), Cells(Sat, SKol - 1)).AutoFilter Field:=BKol, Criteria1:=Liste(i)
        Range("A1").CurrentRegion.Copy
    
        If DosyaSayfa = 1 Then
            Sheets(Liste(i)).Select
            ActiveSheet.Paste
            Cells.EntireColumn.AutoFit
            Range("A1").Select
            ws.Select
        ElseIf DosyaSayfa = 2 Then
            Workbooks.Add
            ActiveSheet.Paste
            Cells.EntireColumn.AutoFit
            Range("A1").Select
            Application.CutCopyMode = False
            ActiveWorkbook.SaveAs Filename:=Yol & DosyaSy & Liste(i), _
                 FileFormat:=Surum, CreateBackup:=False
            ActiveWorkbook.Close Savechanges:=False
        Else
            ActiveSheet.PrintOut
        End If
    Next i
    
    ActiveSheet.ShowAllData
    
    Application.ScreenUpdating = False

    If DosyaSayfa = 1 Then
        Mes = "SAYFALARA"
    Else
        Mes = "DOSYALARA"
    End If
    
    MsgBox Mes & " AKTARIM TAMAMLANMIŞTIR....", vbInformation, "N. YEŞERTENER...."
    
End Sub

'Necdet www.excel.web.tr

Dim i As Long, _
SSat As Long, _
Sat As Long, _
SKol As Integer, _
BKol As Integer, _
DosyaSayfa As Integer, _
Secim As Range, _
rngAlan As Range, _
Liste() As String, _
Yol As String, _
DosyaAd As String, _
DosyaUz As String, _
DosyaSy As String, _
Surum As String, _
Mes As String, _
ws As Worksheet, _
wsNew As Worksheet

Surum = ActiveWorkbook.FileFormat
Set ws = Sheets(ActiveSheet.Name)

On Error Resume Next
Basla:
DosyaSayfa = Application.InputBox("1. SAYFALARA AYIRMA, 2. DOSYALARA AYIRMA, 3. YAZDIR", "YÖNTEM SEÇİMİ.....", 1, Type:=1)
If DosyaSayfa = 0 Then Exit Sub
If DosyaSayfa > 3 Then GoTo Basla

Yol = ActiveWorkbook.Path & Application.PathSeparator
DosyaUz = ".xlsx"
If DosyaSayfa = 2 Then DosyaSy = InputBox("Dosya Adı Ne Olarak Başlasın", "Dosya Adı Girişi")

On Error Resume Next
Application.DisplayAlerts = False

Set Secim = Application.InputBox("Sütunu seçmek için bir hücre(ler) Seçiniz", "N. YEŞERTENER --> Sütun Belirleme", Type:=8)
If Secim Is Nothing Then Exit Sub

With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With

Sat = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
SKol = Cells.Find("*", , , , xlByColumns, xlPrevious).Column + 1
BKol = Secim.Column

Set rngAlan = Range(Cells(1, 1), Cells(Sat, SKol - 1))

Columns(BKol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Cells(1, SKol), Unique:=True
SSat = Cells(Rows.Count, SKol).End(3).Row

ReDim Liste(SSat - 2)

For i = 2 To SSat
Liste(i - 2) = Cells(i, SKol)
Next i

Columns(SKol).Clear
SSat = Cells(Rows.Count, "A").End(3).Row
SKol = SKol - 1

Selection.AutoFilter

If DosyaSayfa = 1 Then
Sheets(Liste).Delete
For i = 0 To UBound(Liste)
Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Liste(i)
Next i
ws.Select
End If

For i = 0 To UBound(Liste)
ActiveSheet.Range(Cells(1, 1), Cells(Sat, SKol - 1)).AutoFilter Field:=BKol, Criteria1:=Liste(i)
Range("A1").CurrentRegion.Copy

If DosyaSayfa = 1 Then
Sheets(Liste(i)).Select
ActiveSheet.Paste
Cells.EntireColumn.AutoFit
Range("A1").Select
ws.Select
ElseIf DosyaSayfa = 2 Then
Workbooks.Add
ActiveSheet.Paste
Cells.EntireColumn.AutoFit
Range("A1").Select
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:=Yol & DosyaSy & Liste(i), _
FileFormat:=Surum, CreateBackup:=False
ActiveWorkbook.Close Savechanges:=False
Else
ActiveSheet.PrintOut
End If
Next i

ActiveSheet.ShowAllData

Application.ScreenUpdating = False

If DosyaSayfa = 1 Then
Mes = "SAYFALARA"
Else
Mes = "DOSYALARA"
End If

MsgBox Mes & " AKTARIM TAMAMLANMIŞTIR....", vbInformation, "N. YEŞERTENER...."

End Sub

 Post reply
 
Preview
Attach files
 
Son sütunda işlem yapmamak?

örnek dosyanızı kodları ile birlikte paylaşır mısınzı?
 
Necdet' Alıntı:
Son sütunda işlem yapmamak?

örnek dosyanızı kodları ile birlikte paylaşır mısınzı?
Genişletmek için tıkla ...
Öncelikle iyi bayramlar diliyorum ve zahmetiniz için teşekkür ediyorum
Örnek dosyamı ve ilgili kodlarla paylaştım.
F sütun hariç diğer tüm sütunlar için çalışıyor. Fakat F sütunundaki veriler için sayfalara ayırmak istediğimde sayfalar oluşuyor fakat içlerine tüm tablo kopyalanıp yapıştırılıyor.
Yani 2002, 2010, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 sayfaları açılıp içlerine ilgili yıllara ait veriler yapıştırmıyor. Tüm tabloyu tüm yıl isimlerindeki sayfalara yapıştırıyor.
F sütunu son sütun olduğu için böyle yapıyor gibi. Çünkü F sütunun yanına başka dolu bir sütun daha oluşturursam(G) bu defa F'de de çalışıyor. Fakat bu defa yeni oluşturduğum G sütunda çalışmıyor. (Son sütunda) Umarım anlatabilmişimdir.
 

Ekli dosyalar

Merhaba,
Yıllar önce yazdığım kod, gerekli kontrolü yapmamışım.
Son dosyanızdaki kodu düzelttim.

Kod: 
Sub Dosyalara_Sayfalara_Ayır()

'Necdet www.excel.web.tr

    Dim i           As Long, _
        SSat        As Long, _
        Sat         As Long, _
        SKol        As Integer, _
        BKol        As Integer, _
        DosyaSayfa  As Integer, _
        Secim       As Range, _
        rngAlan     As Range, _
        Liste()     As String, _
        Yol         As String, _
        DosyaAd     As String, _
        DosyaUz     As String, _
        DosyaSy     As String, _
        Surum       As String, _
        Mes         As String, _
        ws          As Worksheet, _
        wsNew       As Worksheet
        
    Surum = ActiveWorkbook.FileFormat
    Set ws = Sheets(ActiveSheet.Name)
    
    On Error Resume Next
Basla:
    DosyaSayfa = Application.InputBox("1. SAYFALARA AYIRMA, 2. DOSYALARA AYIRMA, 3. YAZDIR", "YÖNTEM SEÇİMİ.....", 1, Type:=1)
    If DosyaSayfa = 0 Then Exit Sub
    If DosyaSayfa > 3 Then GoTo Basla
    
    Yol = ActiveWorkbook.Path & Application.PathSeparator
    DosyaUz = ".xlsx"
    If DosyaSayfa = 2 Then DosyaSy = InputBox("Dosya Adı Ne Olarak Başlasın", "Dosya Adı Girişi")
        
    On Error Resume Next
    Application.DisplayAlerts = False
    
    Set Secim = Application.InputBox("Sütunu seçmek için bir hücre(ler) Seçiniz", "N. YEŞERTENER --> Sütun Belirleme", Type:=8)
    If Secim Is Nothing Then Exit Sub
    
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    
    Sat = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    SKol = Cells.Find("*", , , , xlByColumns, xlPrevious).Column + 1
    BKol = Secim.Column
    
    Set rngAlan = Range(Cells(1, 1), Cells(Sat, SKol - 1))
    
    Columns(BKol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Cells(1, SKol), Unique:=True
'    Columns(BKol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Cells(1, SKol), Unique:=True
    SSat = Cells(Rows.Count, SKol).End(3).Row
    
    ReDim Liste(SSat - 2)
    
    For i = 2 To SSat
        Liste(i - 2) = Cells(i, SKol)
    Next i
    
    Columns(SKol).Clear
    SSat = Cells(Rows.Count, "A").End(3).Row
    SKol = SKol - 1
    
    If ActiveSheet.AutoFilterMode = False Then Range("A1").AutoFilter
    
    If DosyaSayfa = 1 Then
        Sheets(Liste).Delete
        For i = 0 To UBound(Liste)
            Sheets.Add After:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = Liste(i)
        Next i
        ws.Select
    End If
    
    For i = 0 To UBound(Liste)
        ActiveSheet.Range(Cells(1, 1), Cells(Sat, SKol - 1)).AutoFilter Field:=BKol, Criteria1:=Liste(i)
        Range("A1").CurrentRegion.Copy
    
        If DosyaSayfa = 1 Then
            Sheets(Liste(i)).Select
            ActiveSheet.Paste
            Cells.EntireColumn.AutoFit
            Range("A1").Select
            ws.Select
        ElseIf DosyaSayfa = 2 Then
            Workbooks.Add
            ActiveSheet.Paste
            Cells.EntireColumn.AutoFit
            Range("A1").Select
            Application.CutCopyMode = False
            ActiveWorkbook.SaveAs Filename:=Yol & DosyaSy & Liste(i), _
                 FileFormat:=Surum, CreateBackup:=False
            ActiveWorkbook.Close Savechanges:=False
        Else
            ActiveSheet.PrintOut
        End If
    Next i
    
    ActiveSheet.ShowAllData
    
    Application.ScreenUpdating = False

    If DosyaSayfa = 1 Then
        Mes = "SAYFALARA"
    Else
        Mes = "DOSYALARA"
    End If
    
    MsgBox Mes & " AKTARIM TAMAMLANMIŞTIR....", vbInformation, "N. YEŞERTENER...."
    
End Sub
 
Ayrıca 8 ve 9. mesajdaki kodları denediniz mi?
 
Necdet' Alıntı:
Merhaba,
Yıllar önce yazdığım kod, gerekli kontrolü yapmamışım.
Son dosyanızdaki kodu düzelttim.

Kod: 
Sub Dosyalara_Sayfalara_Ayır()

'Necdet www.excel.web.tr

    Dim i           As Long, _
        SSat        As Long, _
        Sat         As Long, _
        SKol        As Integer, _
        BKol        As Integer, _
        DosyaSayfa  As Integer, _
        Secim       As Range, _
        rngAlan     As Range, _
        Liste()     As String, _
        Yol         As String, _
        DosyaAd     As String, _
        DosyaUz     As String, _
        DosyaSy     As String, _
        Surum       As String, _
        Mes         As String, _
        ws          As Worksheet, _
        wsNew       As Worksheet
       
    Surum = ActiveWorkbook.FileFormat
    Set ws = Sheets(ActiveSheet.Name)
   
    On Error Resume Next
Basla:
    DosyaSayfa = Application.InputBox("1. SAYFALARA AYIRMA, 2. DOSYALARA AYIRMA, 3. YAZDIR", "YÖNTEM SEÇİMİ.....", 1, Type:=1)
    If DosyaSayfa = 0 Then Exit Sub
    If DosyaSayfa > 3 Then GoTo Basla
   
    Yol = ActiveWorkbook.Path & Application.PathSeparator
    DosyaUz = ".xlsx"
    If DosyaSayfa = 2 Then DosyaSy = InputBox("Dosya Adı Ne Olarak Başlasın", "Dosya Adı Girişi")
       
    On Error Resume Next
    Application.DisplayAlerts = False
   
    Set Secim = Application.InputBox("Sütunu seçmek için bir hücre(ler) Seçiniz", "N. YEŞERTENER --> Sütun Belirleme", Type:=8)
    If Secim Is Nothing Then Exit Sub
   
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
   
    Sat = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    SKol = Cells.Find("*", , , , xlByColumns, xlPrevious).Column + 1
    BKol = Secim.Column
   
    Set rngAlan = Range(Cells(1, 1), Cells(Sat, SKol - 1))
   
    Columns(BKol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Cells(1, SKol), Unique:=True
'    Columns(BKol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Cells(1, SKol), Unique:=True
    SSat = Cells(Rows.Count, SKol).End(3).Row
   
    ReDim Liste(SSat - 2)
   
    For i = 2 To SSat
        Liste(i - 2) = Cells(i, SKol)
    Next i
   
    Columns(SKol).Clear
    SSat = Cells(Rows.Count, "A").End(3).Row
    SKol = SKol - 1
   
    If ActiveSheet.AutoFilterMode = False Then Range("A1").AutoFilter
   
    If DosyaSayfa = 1 Then
        Sheets(Liste).Delete
        For i = 0 To UBound(Liste)
            Sheets.Add After:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = Liste(i)
        Next i
        ws.Select
    End If
   
    For i = 0 To UBound(Liste)
        ActiveSheet.Range(Cells(1, 1), Cells(Sat, SKol - 1)).AutoFilter Field:=BKol, Criteria1:=Liste(i)
        Range("A1").CurrentRegion.Copy
   
        If DosyaSayfa = 1 Then
            Sheets(Liste(i)).Select
            ActiveSheet.Paste
            Cells.EntireColumn.AutoFit
            Range("A1").Select
            ws.Select
        ElseIf DosyaSayfa = 2 Then
            Workbooks.Add
            ActiveSheet.Paste
            Cells.EntireColumn.AutoFit
            Range("A1").Select
            Application.CutCopyMode = False
            ActiveWorkbook.SaveAs Filename:=Yol & DosyaSy & Liste(i), _
                 FileFormat:=Surum, CreateBackup:=False
            ActiveWorkbook.Close Savechanges:=False
        Else
            ActiveSheet.PrintOut
        End If
    Next i
   
    ActiveSheet.ShowAllData
   
    Application.ScreenUpdating = False

    If DosyaSayfa = 1 Then
        Mes = "SAYFALARA"
    Else
        Mes = "DOSYALARA"
    End If
   
    MsgBox Mes & " AKTARIM TAMAMLANMIŞTIR....", vbInformation, "N. YEŞERTENER...."
   
End Sub
Genişletmek için tıkla ...
Bu çalışma ihtiyacımı tam olarak karşıladı. Diğer 8 ve 9. mesajdaki kodlar la da yapılabiliyor fakat ADO tecrübemin olmamasından dolayı ve bu kodda sayfalara ayır, dosyalara ayır ve yazdır seçenekleri olduğu için bana daha iyi geldi. Yardımız çok kıymetliydi. İlginizden dolayı çok teşekkür ediyorum.
 
Güle güle kullanınız.
Yeni sürüm sayfalara ayır kodlarını yazdım. sıralama ve dizi kullanarak.
Dosya oluştur seçeneğini de eklersem paylaşırım.
Dizi de baya hızlı çalışıyor doğrusu :)
 
Necdet' Alıntı:
Güle güle kullanınız.
Yeni sürüm sayfalara ayır kodlarını yazdım. sıralama ve dizi kullanarak.
Dosya oluştur seçeneğini de eklersem paylaşırım.
Dizi de baya hızlı çalışıyor doğrusu :)
Genişletmek için tıkla ...
çalışmanız bittiğinde paylaşırsanız mutlu olurum.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst