Excel Dosyalara parçalama

celerimbor · 1 Ekim 2021

Merhaba,
Çok Satırlı ve sütunlu excel listelerim var bu listeleri listedeki bir sütuna göre excel dosyalarına bölmek istiyorum

Örn. a sütunundaki veri her değiştiğinde ayrı bir excel dosyası oluştursun (excel dosyasının adı sutünda geçen olacak)

bu konuda yardımcı olabilirseniz sevinirim

Korhan Ayhan · 1 Ekim 2021

Merhaba,

Profilinizde ofis sürümü olarak "excel 97" yazıyor. Eğer bu bilgi doğru değilse lütfen güncelleyiniz.

Aşağıdaki kod A sütunundaki benzersiz verilere göre dosyanızın bulunduğu bölüme "Dosyalar" adında yeni bir klasör oluşturup verilerinizi dosya olarak kayıt eder. Eğer bahsettiğim excel sürümünü kullanıyorsanız kodu revize etmek gerekecektir.

Kod denediğim dosyada 30.000 satır ve 20 sütundan oluşan bir veri seti vardı. Yaklaşık 100 saniye civarında işlemi tammaladı.

C++:

Option Explicit

Sub Verileri_Dosyalara_Aktar()
    Dim K1 As Workbook, S1 As Worksheet
    Dim K2 As Workbook, S2 As Worksheet
    Dim Dizi As Object, Yol As String
    Dim Aranan As Variant, Onay As Byte
    Dim Son As Long, X As Long, Veri As Variant
    Dim Y As Integer, Say As Long, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("Sheet1")
    Set Dizi = VBA.CreateObject("Scripting.Dictionary")
    
    Yol = K1.Path & "\Dosyalar\"
    
    If Dir(Yol, vbDirectory) = "" Then
        MkDir Yol
    Else
        If VBA.CreateObject("Scripting.FileSystemObject").Getfolder(Yol).Files.Count > 0 Then Kill Yol & "*.*"
    End If
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son < 3 Then Son = 3
    
    Veri = S1.Range("A1:T" & Son).Value
    
    For X = 2 To UBound(Veri, 1)
        Dizi.Item(Veri(X, 1)) = 1
    Next
    
    For Each Aranan In Dizi.Keys
        ReDim Liste(1 To S1.Rows.Count, 1 To 20)
        
        Say = Say + 1
        
        For Y = 1 To UBound(Liste, 2)
            Liste(Say, Y) = Veri(1, Y)
        Next
        
        For X = 2 To UBound(Veri, 1)
            If Veri(X, 1) = Aranan Then
                Say = Say + 1
                For Y = 1 To UBound(Liste, 2)
                    Liste(Say, Y) = Veri(X, Y)
                Next
            End If
        Next
        
        If Say > 0 Then
            Set K2 = Workbooks.Add(1)
            Set S2 = K2.Sheets(1)
            S2.Range("A1").Resize(Say, UBound(Liste, 2)) = Liste
            S2.Range("A1").Resize(, UBound(Liste, 2)).Font.Bold = True
            K2.SaveAs Yol & Aranan & ".xlsx", 51, Local:=True
            K2.Close
            Say = 0
        End If
        
        Erase Liste
    Next
    
    Set K1 = Nothing
    Set S1 = Nothing
    Set K2 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    Onay = MsgBox("A sütunundaki verilerinize göre oluşturulan dosyalar aşağıdaki klasöre kayıt edilmiştir." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye" & vbCr & vbCr & Yol & vbCr & vbCr & _
           "Klasörü açmak ister misiniz?", vbYesNo)
    If Onay = vbYes Then
        Call Shell("Explorer.exe" & " " & Yol, vbNormalFocus)
    End If
End Sub

Necdet · 2 Ekim 2021

Merhaba,
Alternatif olsun.
Yıllar önce kendi gereksinimim için yazdığım kodları buldum.
Sizin seçtiğiniz Sütuna göre benzerleri gruplayıp, ister sayfalara (Sheet), ister dosyaya isterseniz doğrudan yazıcıya gönderen kodları bir modüle kopyalayıp deneyiniz.

Kod:

Sub Dosyalara_Sayfalara_Ayır()
                                'Necdet
    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, "Necdet ...."
   
End Sub

celerimbor · 14 Ekim 2021

Korhan Ayhan' Alıntı:

Merhaba,

Profilinizde ofis sürümü olarak "excel 97" yazıyor. Eğer bu bilgi doğru değilse lütfen güncelleyiniz.

Aşağıdaki kod A sütunundaki benzersiz verilere göre dosyanızın bulunduğu bölüme "Dosyalar" adında yeni bir klasör oluşturup verilerinizi dosya olarak kayıt eder. Eğer bahsettiğim excel sürümünü kullanıyorsanız kodu revize etmek gerekecektir.

Kod denediğim dosyada 30.000 satır ve 20 sütundan oluşan bir veri seti vardı. Yaklaşık 100 saniye civarında işlemi tammaladı.

C++:

Option Explicit

Sub Verileri_Dosyalara_Aktar()
    Dim K1 As Workbook, S1 As Worksheet
    Dim K2 As Workbook, S2 As Worksheet
    Dim Dizi As Object, Yol As String
    Dim Aranan As Variant, Onay As Byte
    Dim Son As Long, X As Long, Veri As Variant
    Dim Y As Integer, Say As Long, Zaman As Double
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("Sheet1")
    Set Dizi = VBA.CreateObject("Scripting.Dictionary")
   
    Yol = K1.Path & "\Dosyalar\"
   
    If Dir(Yol, vbDirectory) = "" Then
        MkDir Yol
    Else
        If VBA.CreateObject("Scripting.FileSystemObject").Getfolder(Yol).Files.Count > 0 Then Kill Yol & "*.*"
    End If
   
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son < 3 Then Son = 3
   
    Veri = S1.Range("A1:T" & Son).Value
   
    For X = 2 To UBound(Veri, 1)
        Dizi.Item(Veri(X, 1)) = 1
    Next
   
    For Each Aranan In Dizi.Keys
        ReDim Liste(1 To S1.Rows.Count, 1 To 20)
       
        Say = Say + 1
       
        For Y = 1 To UBound(Liste, 2)
            Liste(Say, Y) = Veri(1, Y)
        Next
       
        For X = 2 To UBound(Veri, 1)
            If Veri(X, 1) = Aranan Then
                Say = Say + 1
                For Y = 1 To UBound(Liste, 2)
                    Liste(Say, Y) = Veri(X, Y)
                Next
            End If
        Next
       
        If Say > 0 Then
            Set K2 = Workbooks.Add(1)
            Set S2 = K2.Sheets(1)
            S2.Range("A1").Resize(Say, UBound(Liste, 2)) = Liste
            S2.Range("A1").Resize(, UBound(Liste, 2)).Font.Bold = True
            K2.SaveAs Yol & Aranan & ".xlsx", 51, Local:=True
            K2.Close
            Say = 0
        End If
       
        Erase Liste
    Next
   
    Set K1 = Nothing
    Set S1 = Nothing
    Set K2 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
   
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
   
    Onay = MsgBox("A sütunundaki verilerinize göre oluşturulan dosyalar aşağıdaki klasöre kayıt edilmiştir." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye" & vbCr & vbCr & Yol & vbCr & vbCr & _
           "Klasörü açmak ister misiniz?", vbYesNo)
    If Onay = vbYes Then
        Call Shell("Explorer.exe" & " " & Yol, vbNormalFocus)
    End If
End Sub

forumu çok fazla kullanmadığımdan gözden kaçmış güncelledim excel 2016 kullanıyorum teşekkürler

celerimbor · 14 Ekim 2021

Necdet' Alıntı:

Merhaba,
Alternatif olsun.
Yıllar önce kendi gereksinimim için yazdığım kodları buldum.
Sizin seçtiğiniz Sütuna göre benzerleri gruplayıp, ister sayfalara (Sheet), ister dosyaya isterseniz doğrudan yazıcıya gönderen kodları bir modüle kopyalayıp deneyiniz.

Kod:

Sub Dosyalara_Sayfalara_Ayır()
                                'Necdet
    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, "Necdet ...."
  
End Sub

Kusura bakmayın geç oldu ama çok işime yaradı teşekkürler

Excel Dosyalara parçalama

celerimbor

Korhan Ayhan

Administrator

Necdet

Moderatör

celerimbor

celerimbor