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

bulentkars · 22 Haziran 2022

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

Necdet · 22 Haziran 2022

Merhaba,

Aşağıdaki linkteki 4 nolu yanıt işinize yarar mı?

İNCELEYİNİZ

bulentkars · 22 Haziran 2022

Necdet Bey,

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

Necdet · 22 Haziran 2022

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 · 22 Haziran 2022

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 · 22 Haziran 2022

Merhaba,
Kodlar bana ait, sağolun.

kodları inceleyin dediklerinizi yapabilirsiniz diye umuyorum.

bulentkars · 22 Haziran 2022

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 · 22 Haziran 2022

Kodlar bu hali ile ihtiyacınızı karşılıyor mu?

bulentkars · 22 Haziran 2022

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 · 22 Haziran 2022

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 · 22 Haziran 2022

Necdet Bey,

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

bulentkars · 22 Haziran 2022

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 · 23 Haziran 2022

Merhaba,

Surum = ActiveWorkbook.FileFormat

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

bulentkars · 23 Haziran 2022

Necdet bey,

Çok teşekkür ederim. oldu. elinize sağlık

Necdet · 23 Haziran 2022

güle güle kullanınız

bulentkars · 28 Haziran 2022

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 · 29 Haziran 2022

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 · 29 Haziran 2022

Necdet Bey

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

Necdet · 29 Haziran 2022

bu işlerde kusur olmaz

bulentkars · 14 Temmuz 2022

Necdet Bey,

#12 Nolu sorun halen devam etmekte, Dosyayı bir türlü xlsx formatında kaydedemiyorum, daha önce ana dosya uzantısı xlsb id, xlsm yaptım kayıt yaparken xlsm olarak kayıt yapıyor. dosya ekte dosyaların xlsx formatında kayıt yapmak istiyorum. yardımcı olabilirseniz sevinirim. Şİmdiden teşekkürler

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

bulentkars

Ekli dosyalar

Necdet

Moderatör

bulentkars

Necdet

Moderatör

bulentkars

Necdet

Moderatör

bulentkars

Necdet

Moderatör

bulentkars

Necdet

Moderatör

bulentkars

bulentkars

Necdet

Moderatör

bulentkars

Necdet

Moderatör

bulentkars

Necdet

Moderatör

bulentkars

Necdet

Moderatör

bulentkars

Ekli dosyalar