Excel 'de Datayı Bolmek

Registered · 19 Şubat 2010

elimde 5200 satırlık bir data var, sadece tek hucre (a-1 ile a-5200)
yapmak istedigim şu;
5200 luk datayı 100 'er parcalar haline bolmek, ve farklı excel dosyaları yaratmak. yani 52 tane xls dosyası olması gerekiyor farklı isimlerde?
bunu nasıl yaparım, sanırım macro gerekecek

yardımlarınızı rica ederim.

Registered · 22 Şubat 2010

cvp verecek yokmu arkadaslar acil lazım.

Necdet · 22 Şubat 2010

Merhaba,

Aşağıdaki kodları dener misiniz?

Verilerinizi DOSYA_AYIR dosyasına kopyalayın ve makroyu çalıştırın, bulunduğunuz yol da dosyalar oluşturulur. Kırmızı ile belirtilen 10 değerini kendinize göre ayarlayınız.

Bu örnekte 10 arlı satırlar halinde dosya oluşturuluyor.

Kod:

Sub Baska_Dosyaya_Yaz()

    Dim i           As Long
    Dim j           As Integer
    Dim SonKol      As Integer
    Dim Yol         As String
    Dim Dosya_Ad    As String
    Dim SatirAdedi  As Long
    Dim BuDosya     As String
    Dim NewBook     As Workbook
    
    BuDosya = ThisWorkbook.Name
    
    Yol = ThisWorkbook.Path & Application.PathSeparator
    SatirAdedi = 100000
    Application.ScreenUpdating = False
    SonKol = [IV1].End(1).Column
    For i = 2 To Cells(Rows.Count, "A").End(3).Row Step SatirAdedi
       j = j + 1
       Dosya_Ad = "Dosya-" & j
        Set NewBook = Workbooks.Add
            With NewBook
                .Title = "www.excel.web.tr Tarafından Programatik Olarak Oluşturuldu"
                .Subject = "Dosya Bölme"
                .SaveAs Filename:=Yol & Dosya_Ad & ".xlsx"
            End With
            ActiveWorkbook.Close True
        Workbooks.Open Filename:=Yol & Dosya_Ad & ".xlsx"
        
        Windows(BuDosya).Activate
        Range(Cells(1, "A"), Cells(1, SonKol)).Select
        Selection.Copy
        Windows(Dosya_Ad & ".xlsx").Activate
        Sheets(1).Range("A1").Select
        ActiveSheet.Paste
        Windows(BuDosya).Activate
        Range(Cells(i, "A"), Cells(i + SatirAdedi - 1, SonKol)).Select
        Selection.Copy
        
        Windows(Dosya_Ad & ".xlsx").Activate
        Sheets(1).Range("A2").Select
        ActiveSheet.Paste
        [A1].Select
        ActiveWorkbook.Close True
        
        Application.CutCopyMode = False
            
    Next i
    
    [A1].Select
    
    MsgBox "Aktarım İşlemi Bitmiştir..........."
    
End Sub

Registered · 23 Şubat 2010

çok tesekkur ederim.

harunsengel · 18 Eylül 2013

Konuyu hortlattığım için özür dilerim.

Aynı sorun bendede mevcut fakat data 1 milyon olduğu için verdiğiniz bu makro çalışıyor gözüküyor işlem bitmiştir diyor ama dosyaları ayırmıyor.

Bu kodu 2007 veya 2010 için nasıl yapabiliriz.

harunsengel · 18 Eylül 2013

Çözümü buldum başkalarının ihtiyacı olabilir diye paylaşıyorum.

Sub DOSYALARA_AKTAR()
Dim D1 As Workbook, D2 As Workbook, S1 As Worksheet, X As Long
Dim Satir As Long, Dosya_Adi As String, Ek As String
Dim Son_Satir As Long, Say As Integer, Zaman As Double

On Error Resume Next

Zaman = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False

Set D1 = ThisWorkbook
Set S1 = D1.Sheets("Sayfa1")

Satir = 50000
Say = 1
Ek = Format(Say, "000")
Dosya_Adi = D1.Path & "\Dosya_" & Ek
Son_Satir = S1.Cells(Rows.Count, 1).End(3).Row

For X = 2 To Son_Satir Step Satir
Set D2 = Workbooks.Add
S1.Range("A1:H1").Copy D2.Sheets(1).Range("A1")
If X + Satir <= Son_Satir Then
S1.Range("A" & X & ":H" & X + Satir).Copy D2.Sheets(1).Range("A2")
Else
S1.Range("A" & X & ":H" & Son_Satir).Copy D2.Sheets(1).Range("A2")
End If
D2.SaveAs Dosya_Adi
D2.Close 0
Say = Say + 1
Ek = Format(Say, "000")
Dosya_Adi = D1.Path & "\Dosya_" & Ek
Next
Set S1 = Nothing
Set D1 = Nothing
Set D2 = Nothing

Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

MsgBox "İşleminiz ; " & Format(Timer - Zaman, "0.000") & " saniyede tamamlanmıştır.", vbInformation
End Sub

ysf-drsn · 9 Mayıs 2017

konuyu hortlatayım. yeni konu açtım ama buradakine yakın mantıkta benim sorunumda. excel i bölme işlemi ama satır bazlı değil de şube kodlarına göre ayrılması lazım. her şubenin farklı sayıda satırları var. Bunu nasıl yapabiliriz.

kaydina · 7 Mart 2018

Kodlar benim dosyamda tam çalışmadı her çalıştırmamda 0,027 sn sürmüştür deyip işlem yapmıyor. Dosyamda 870k satır var

Necdet · 7 Mart 2018

harunsengel' Alıntı:
Konuyu hortlattığım için özür dilerim.

Aynı sorun bendede mevcut fakat data 1 milyon olduğu için verdiğiniz bu makro çalışıyor gözüküyor işlem bitmiştir diyor ama dosyaları ayırmıyor.

Bu kodu 2007 veya 2010 için nasıl yapabiliriz.

Verdiğim kodlar 2003 sürümü için geçerliydi, malum 65536 satır vardı. Kodları düzelttim ilk mesajımda.

Necdet · 7 Mart 2018

ysf-drsn' Alıntı:
konuyu hortlatayım. yeni konu açtım ama buradakine yakın mantıkta benim sorunumda. excel i bölme işlemi ama satır bazlı değil de şube kodlarına göre ayrılması lazım. her şubenin farklı sayıda satırları var. Bunu nasıl yapabiliriz.

Yeni gördüm

Aşağıdaki kodlar belli sayfayı ölçüte göre sayfalara ya da dosyalara ayırır.

Kod:

Sub Dosyalara_Sayfalara_Ayır()

    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

sametozyavuz · 7 Mart 2018

Teşekküler.

Forumda neler var diye gezerken gördüğüm bu kod benim için de çok faydalı oldu. Bende emeğinize sağlık diyorum.

kaydina · 7 Mart 2018

Benim dosyamın boyutundan dolayımı bilmiyorum 790 bin satır var 10 biner ayırmak istiyorum fakat yeni dosya açıyor başka bir işlem yapmıyor https://yadi.sk/d/2ePB8KBU3T7bMh

Necdet · 7 Mart 2018

kaydina' Alıntı:
Benim dosyamın boyutundan dolayımı bilmiyorum 790 bin satır var 10 biner ayırmak istiyorum fakat yeni dosya açıyor başka bir işlem yapmıyor https://yadi.sk/d/2ePB8KBU3T7bMh

Merhaba,

3. mesajımdaki kodları düzelttim. Kodlar baya eksi kalmış. Sizin dosyanızda denedim çalıştı.

Not : Kodları bir modüle kopyalayıp deneyiniz.

Excel 'de Datayı Bolmek

Registered

Registered

Necdet

Moderatör

Registered

harunsengel

harunsengel

ysf-drsn

kaydina

Necdet

Moderatör

Necdet

Moderatör

sametozyavuz

kaydina

Necdet

Moderatör