Excel 'de Datayı Bolmek

R

Registered

Katılım
12 Ağustos 2007
Mesajlar
36
Excel Vers. ve Dili
MS OFFiCE 2010 - İngilizce
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.
 
N

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,491
Excel Vers. ve Dili
Ofis 365 Türkçe
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
 
H

harunsengel

Katılım
11 Şubat 2013
Mesajlar
2
Excel Vers. ve Dili
normal
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.
 
H

harunsengel

Katılım
11 Şubat 2013
Mesajlar
2
Excel Vers. ve Dili
normal
Çö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
Genişletmek için tıkla ...
 
Y

ysf-drsn

Katılım
11 Ocak 2011
Mesajlar
25
Excel Vers. ve Dili
2007 EXCEL - TÜRKÇE
2013 excel
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.
 
K

kaydina

Katılım
1 Ağustos 2017
Mesajlar
15
Excel Vers. ve Dili
2013 Türkçe
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
 
N

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,491
Excel Vers. ve Dili
Ofis 365 Türkçe
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.
Genişletmek için tıkla ...
Verdiğim kodlar 2003 sürümü için geçerliydi, malum 65536 satır vardı. Kodları düzelttim ilk mesajımda.
 
N

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,491
Excel Vers. ve Dili
Ofis 365 Türkçe
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.
Genişletmek için tıkla ...
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
 
S

sametozyavuz

Katılım
6 Mart 2008
Mesajlar
282
Excel Vers. ve Dili
2021 Türkçe
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.
 
N

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,491
Excel Vers. ve Dili
Ofis 365 Türkçe
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
Genişletmek için tıkla ...
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.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst