Soru D Sütünuna göre Kitaplara ayırmak

bulentkars

Altın Üye
Katılım
5 Ağustos 2005
Mesajlar
423
Excel Vers. ve Dili
2003 TR
Arkadaşlar Merhaba,

Ekreki tabloda detaylıca belirttim.
A1:F aralığında satış elemanlarının bilgileri var. Ben satış elemanlarının D sutunundaki isimlerine göre dosyaları C:EXTRE\ Klasörü içerisine xls olarak kaydetmek istiyorum. yardımcı olabilirseniz sevinirim. Şİmdiden Teşekkürler
 

Ekli dosyalar

bulentkars

Altın Üye
Katılım
5 Ağustos 2005
Mesajlar
423
Excel Vers. ve Dili
2003 TR
Necdet Bey,

Link bende açılmıyor. buradan paylaşmanız münkün mü acaba
 

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
13,808
Excel Vers. ve Dili
Ofis 365 Türkçe
Açılması gerek, neden açılmıyor anlamadım.

Buyrunuz Kodlar :
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
    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
 

bulentkars

Altın Üye
Katılım
5 Ağustos 2005
Mesajlar
423
Excel Vers. ve Dili
2003 TR
Necdet Bey,

Çok güzel bir çalışma yapanın eline koluna sağlık. Bunu farklı projeler için kullanabilirim.
Bu dosyada ufak değişiklik yapabilirsek çok sevinirim.

Makro çalıştığında
İnputbox ile soru sormasın,
işlem Dosyalara ayırma olacak.
Dosya adı ne olarak başlasın olmayacak.
Sutunu seçmek için hücre D satırı olacak.
ve kayıt yeri C:\EXTRE\ Klasörü olacak.
bu şekilde düzeltme yapabilirseniz çok sevinirim. teşekkürler
 

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
13,808
Excel Vers. ve Dili
Ofis 365 Türkçe
Merhaba,
Kodlar bana ait, sağolun.

kodları inceleyin dediklerinizi yapabilirsiniz diye umuyorum.
 

bulentkars

Altın Üye
Katılım
5 Ağustos 2005
Mesajlar
423
Excel Vers. ve Dili
2003 TR
Necdet bey, inceliyorum, malesef yapamadım, bu koda çok ihtiyacım var. vakit ayırıp revize edebilirseniz gerçekten çok iyi olur. teşekkürler
 

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
13,808
Excel Vers. ve Dili
Ofis 365 Türkçe
Kodlar bu hali ile ihtiyacınızı karşılıyor mu?
 

bulentkars

Altın Üye
Katılım
5 Ağustos 2005
Mesajlar
423
Excel Vers. ve Dili
2003 TR
Evet Necdet bey
Sadece
Makro çalıştığında
İnputbox ile soru sormasın,
işlem Dosyalara ayırma olacak.
Dosya adı ne olarak başlasın olmayacak.
Sutunu seçmek için hücre D satırı olacak.
ve kayıt yeri C:\EXTRE\ Klasörü olacak.
bu şekilde düzeltme yapabilirseniz çok sevinirim. teşekkürler. Soru sormadan direk çalışmasını istiyorum.
 

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
13,808
Excel Vers. ve Dili
Ofis 365 Türkçe
Mevut kodları koruyarak gereksiz yerleri çıkarttım.

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
    DosyaSayfa = 2
'    Yol = ActiveWorkbook.Path & Application.PathSeparator
    Yol = "C:\EXTRE\"
    DosyaUz = ".xls"
'    If DosyaSayfa = 2 Then DosyaSy = InputBox("Dosya Adı Ne Olarak Başlasın", "Dosya Adı Girişi")
    DosyaSy = ""
    
    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
    BKol = 4
    
    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
 

bulentkars

Altın Üye
Katılım
5 Ağustos 2005
Mesajlar
423
Excel Vers. ve Dili
2003 TR
Necdet Bey,

Sonsuz Teşekkür ediyorum. Elinize sağlık
 

bulentkars

Altın Üye
Katılım
5 Ağustos 2005
Mesajlar
423
Excel Vers. ve Dili
2003 TR
Necdet Bey Merhaba,

Bir sorun fark etttim neden dir acaba bulamadım.
DosyaUz = ".xls"
ben xlsx olarak düzelttim. buna rağmen dosyaları xlsb olarak kaydediyor.
bu arada makronun olduğu çalışma kitabım xlsb uzantılı dosya.
ben xlsx olarak kaydetmesini istiyorum, çünkü mail atarken telefonalarda xlsb uzantılı dosyalar açılmıyor.
 

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
13,808
Excel Vers. ve Dili
Ofis 365 Türkçe
Merhaba,

Surum = ActiveWorkbook.FileFormat

yerine doğrudan Surum = 52
yazarak dener misiniz.
Bende dosyaları xlsx olarak kaydediyor.
 

bulentkars

Altın Üye
Katılım
5 Ağustos 2005
Mesajlar
423
Excel Vers. ve Dili
2003 TR
Necdet Bey İyi Akşamlar

İsimleri sayfalara bölme yazdırma ve Kitaplara ayırma çalışmanız gerçekten takdire şayan tekrar emeğinize yüreğinize sağlık. Bu çalışmaya klasör altındaki Excel dosyalarını birleştirme seçeneği de eklersiniz bir çok ofis çalışanın işine yarayacaktır.
Talebim şu şekilde

İnput box ta mevcut olan
1-SAYFALARA AYIRMA
2-DOSYALARA AYIRMA
3- YAZDIRMA
4- DOSYALARI BİRLEŞTİRME ilave edilip, 4 seçeneği seçildiğinde Dosya Gözat penceresi açılacak gösterilecek klasör altındaki çalışma kitapları alt alta kopyalanacak. Bu vesile ile bu çalışma bir çok kişinin içini kolaylaştıracaktır.
Bu talebimi değerlendire bilirseniz sevinirim. İyi akşamlar.
 

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
13,808
Excel Vers. ve Dili
Ofis 365 Türkçe
Merhaba,

Dosyaları bir sayfada birleştirme forumda baya işlendi, gerek olduğunu sanmıyorum.
Ama siz vba konusunda ilerlediğinizde eklemeleri yapabileceğinize inanıyorum.
Yavaş yavaş, acele etmeye gerek yok.
Biz de halaaa öğreniyoruz :)
hatta ileri aşamalarda bu konuyu yapan eklenti bile yapabilirsiniz.
 

bulentkars

Altın Üye
Katılım
5 Ağustos 2005
Mesajlar
423
Excel Vers. ve Dili
2003 TR
Necdet Bey

Teşekkürler.
Ben biraz tez canlıyım belki ondan yazdım. Kusuruma bakmayın lütfen.
 

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
13,808
Excel Vers. ve Dili
Ofis 365 Türkçe
bu işlerde kusur olmaz :)
 
Üst