7000 bin satırlı excel dosyamı 120 satırlı dosyalar haline getirebilir miyim?

konsilyer · 5 Mayıs 2020

Bir excel dosyam var yedi bin satır, bunu 120 şer satır lar halinde bölüp 60 farklı dosya halinde getiriyorum. Bunu daha kolay bir yolla yapabilir miyim?

Muzaffer Ali · 5 Mayıs 2020

Merhaba.

7000 satır olan sayfanın adını sağ tıklatın, Kod Görüntüle seçin, açılan sayfaya aşağıdaki kodları kopyalayın çalıştırın.

Kod:

Sub Test()
    Dim Bak As Long
    Dim Say As Long
    Dim Sira As Integer
    
    Say = ThisWorkbook.ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
    For Bak = 2 To Say Step 120
        Workbooks.Add
        ThisWorkbook.ActiveSheet.Rows("1:1").Copy ActiveWorkbook.ActiveSheet.Range("A1")
        ThisWorkbook.ActiveSheet.Rows(Bak - 120 & ":" & Bak).Copy ActiveWorkbook.ActiveSheet.Range("B1")
        Sira = 1 + Sira
        ActiveWorkbook.Close True, ThisWorkbook.Path & "\" & Sira
    Next
    MsgBox "Tamamlandı."
End Sub

Yeni dosyalar dosyanızla aynı klasöre kaydedilecektir.

kulomer46 · 5 Mayıs 2020

Merhaba

Alternatif olarak Ana Sayfada bulunan verileri (Örneğin 7000 satır) kullanıcının belirlediği satır adedi kadar,
aynı dosyada diğer sayfalara aktaran programda Ek 'tedir.

Selamlar...

Örnek Resim

İlgili Kod

Kod:

Sub Aktar()
'05.05.2020   10:58

Sheets("Ana Sayfa").Select

son = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1

satıradedi = InputBox("Bu Sayfada Bulanan Verilerin Satır Sayısı " & son & Chr(10) & Chr(10) _
& "Verileri Dağıtmak istediğiniz Satır Adedini Giriniz", "Dağıtım", 120)

If satıradedi = "" Then Exit Sub

c = MsgBox("Ana Sayfa hariç diğer tüm sayfalar silinip Dağıtıma Başlanacaktır." & Chr(10) & _
Chr(10) & "Onaylıyor musunuz?", vbOKCancel, "Dağıtım")

If c = vbCancel Then Exit Sub

If satıradedi < 1 Then satıradedi = 120
If satıradedi > 60000 Then satıradedi = 120

a:
For ii = 1 To Sheets.Count
   
    If Sheets(ii).Name <> "Ana Sayfa" Then

        Application.DisplayAlerts = False
        Worksheets(ii).Delete
        Application.DisplayAlerts = True
        GoTo a

    End If

Next

timer1 = Timer
Do While Timer - timer1 < 0.5
Loop

Application.ScreenUpdating = False
   
For i = 1 To son Step satıradedi

    Say = Say + 1

    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = Say & ".   " & satıradedi & " Satır"
    Sheets("Ana Sayfa").Select
    Rows(i & ":" & i + satıradedi - 1).Select
    Selection.Copy
    Sheets(Say & ".   " & satıradedi & " Satır").Select
    Rows("1:1").Select
    ActiveSheet.Paste
    Cells(1, 1).Select
   
Next

Sheets("Ana Sayfa").Select
Cells(1, 1).Select
   
Application.CutCopyMode = False

Application.ScreenUpdating = True

MsgBox "Ana Sayfada bulunan  " & son & "  Adet Satır" & Chr(10) & Chr(10) & "Her Biri  " _
& satıradedi & "  Satır Halinde " & Chr(10) & Chr(10) & Say & "  Adet Sayfaya Dağıtıldı", , "Dağıtım"

End Sub

konsilyer · 5 Mayıs 2020

İlginiz için çok teşekkür ederim öncelikle yaptıklarımı anlatayım,
exel im de kod görüntüle diye bir yer bulamadım, üst menüye geliştirici sekmesi ekledim, açılan bölümde visual basic iconuna tıkladım, bu çalışma kitabının altında yer alam dosyama sağ tıklayıp wiev code dedim, açılan alana sizin yazdığınız kodu kopyala yapıştır yaptım. kaydet deyip daha sonra play tuşuna bastım, klasörümün içerisine bir dosya kaydetti ancak benim sayfamın sadece ilk satır bilgileri var ,yanlış bir şey yapmış olabilirmiyim

kulomer46 · 5 Mayıs 2020

Değerli Arkadaşım Tekrar Merhaba

Sayın dalgalikur arkadaşımızın emeğine saygı duyarak, yukardaki 2 numaralı mesajının biraz daha gelişmiş halini ekliyorum.
İlgili dosyada Ek 'tedir.

Faydalı olması umuduyla
Selamlar...

Kod:

Sub Aktar1()
'05.05.2020   13:33

Sheets("Ana Sayfa").Select
son = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1

satıradedi = InputBox("Bu Sayfada Bulanan Verilerin Satır Sayısı " & son & Chr(10) & Chr(10) _
& "Verileri Dağıtmak istediğiniz Satır Adedini Giriniz", "Yeni Excel Dosyalarına Dağıtım", 120)

If satıradedi = "" Then Exit Sub

If satıradedi < 1 Then satıradedi = 120
If satıradedi > 60000 Then satıradedi = 120

Application.ScreenUpdating = False
      
    Say = ThisWorkbook.ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
    kaynak = ThisWorkbook.Name

    For Bak = 1 To son Step satıradedi          
            Sira = 1 + Sira
            Workbooks.Add
          
            Workbooks(kaynak).ActiveSheet.Rows(Bak & ":" & Bak + satıradedi - 1).Copy
          
            Rows("1:" & satıradedi).Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
          
            m = Int(son / satıradedi)
            If Sira <= m Then
                sat = satıradedi
            Else
                sat = son - (satıradedi * (Sira - 1))
            End If
          
            ChDir ThisWorkbook.Path          
          
            ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Sira & ".  Dosya (" & sat & "  Satır).xlsx", _
            FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
          
            ActiveWorkbook.Close
    Next
  
Application.CutCopyMode = False

Application.ScreenUpdating = True

MsgBox "Ana Sayfada bulunan  " & son & "  Adet Satır" & Chr(10) & Chr(10) & "Her Biri  " _
& satıradedi & "  Satır Halinde " & Chr(10) & Chr(10) & Sira & "  Adet Yeni Excel Dosyalarına Dağıtıldı ve Kaydedildi", , "Yeni Excel Dosyalarına Dağıtım"

End Sub

bmutlu966 · 5 Mayıs 2020

Sanırım işinizi görecektir. Datanızı bu dosyaya yapıştırıp deneyin. 50 dosyayı tahmini 1 dk da hazırlar. Hazırladığı dosyaları programın bulunduğu klasöre sıra no vererek kaydeder.

konsilyer · 5 Mayıs 2020

Öncelikle tüm mesajlar için teşekkür ederim ancak
kulomer46 sizin mesajınızda run time error 1004 hatası veriyor

---------------
bmutlu966 size de teşekkür ederim ancak sanırım altın üye olmadığım için dosyaya erişim iznim yok bakamıyorum,

ilginiz için tekrar teşekkür ederim.

kulomer46 · 5 Mayıs 2020

konsilyer' Alıntı:
Öncelikle tüm mesajlar için teşekkür ederim ancak
kulomer46 sizin mesajınızda run time error 1004 hatası veriyor

---------------
ilginiz için tekrar teşekkür ederim.

Merhaba

Hatanın giderilmesi için, yukardaki 5 numaralı mesajımda 3. satırdaki "Sheets("Ana Sayfa").Select" satırını tamamen silmeniz yeterlidir.
Birde işlem yaptığınız dosyayı bilgisayara kaydetmeden işlem yapıyorsanız, bilgisayara kaydettikten sonra işlem yapmanız daha yararlı olur.

Selamlar...

konsilyer · 5 Mayıs 2020

Tüm cevap yazanlara çok teşekkür ederim, dediğiniz 3.satırı kaldırınca sayın kulomer46 hata giderildi hatta esasen csv formatında gerekli idi, kod da değişiklikle o sorun da çözüldü, tekrar teşekkür ederim.

kulomer46 · 5 Mayıs 2020

konsilyer' Alıntı:
Tüm cevap yazanlara çok teşekkür ederim, dediğiniz 3.satırı kaldırınca sayın kulomer46 hata giderildi hatta esasen csv formatında gerekli idi, kod da değişiklikle o sorun da çözüldü, tekrar teşekkür ederim.

Selamlar...

metin_0606 · 5 Mayıs 2020

bmutlu966' Alıntı:
Sanırım işinizi görecektir. Datanızı bu dosyaya yapıştırıp deneyin. 50 dosyayı tahmini 1 dk da hazırlar. Hazırladığı dosyaları programın bulunduğu klasöre sıra no vererek kaydeder.

Bu çalışmayı bir klasör içine atıp data kısmına verileri kaydedip makroyu çalıştırdığımda makro çalışıp işlem tamam diyor ama dosyaları herhangi bir yere bölmüyor sorun ne olabilir acaba

metin_0606 · 5 Mayıs 2020

kulomer46' Alıntı:

Değerli Arkadaşım Tekrar Merhaba

Sayın dalgalikur arkadaşımızın emeğine saygı duyarak, yukardaki 2 numaralı mesajının biraz daha gelişmiş halini ekliyorum.
İlgili dosyada Ek 'tedir.

Faydalı olması umuduyla
Selamlar...

Kod:

Sub Aktar1()
'05.05.2020   13:33

Sheets("Ana Sayfa").Select
son = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1

satıradedi = InputBox("Bu Sayfada Bulanan Verilerin Satır Sayısı " & son & Chr(10) & Chr(10) _
& "Verileri Dağıtmak istediğiniz Satır Adedini Giriniz", "Yeni Excel Dosyalarına Dağıtım", 120)

If satıradedi = "" Then Exit Sub

If satıradedi < 1 Then satıradedi = 120
If satıradedi > 60000 Then satıradedi = 120

Application.ScreenUpdating = False
     
    Say = ThisWorkbook.ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
    kaynak = ThisWorkbook.Name

    For Bak = 1 To son Step satıradedi         
            Sira = 1 + Sira
            Workbooks.Add
         
            Workbooks(kaynak).ActiveSheet.Rows(Bak & ":" & Bak + satıradedi - 1).Copy
         
            Rows("1:" & satıradedi).Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
         
            m = Int(son / satıradedi)
            If Sira <= m Then
                sat = satıradedi
            Else
                sat = son - (satıradedi * (Sira - 1))
            End If
         
            ChDir ThisWorkbook.Path         
         
            ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Sira & ".  Dosya (" & sat & "  Satır).xlsx", _
            FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
         
            ActiveWorkbook.Close
    Next
 
Application.CutCopyMode = False

Application.ScreenUpdating = True

MsgBox "Ana Sayfada bulunan  " & son & "  Adet Satır" & Chr(10) & Chr(10) & "Her Biri  " _
& satıradedi & "  Satır Halinde " & Chr(10) & Chr(10) & Sira & "  Adet Yeni Excel Dosyalarına Dağıtıldı ve Kaydedildi", , "Yeni Excel Dosyalarına Dağıtım"

End Sub

Sayın kulomer46 Sayfalara bölerken her bir sayfa için başlık kısmınıda kopyalatabilirmiyiz acaba

Muzaffer Ali · 5 Mayıs 2020

konsilyer' Alıntı:
İlginiz için çok teşekkür ederim öncelikle yaptıklarımı anlatayım,
exel im de kod görüntüle diye bir yer bulamadım, üst menüye geliştirici sekmesi ekledim, açılan bölümde visual basic iconuna tıkladım, bu çalışma kitabının altında yer alam dosyama sağ tıklayıp wiev code dedim, açılan alana sizin yazdığınız kodu kopyala yapıştır yaptım. kaydet deyip daha sonra play tuşuna bastım, klasörümün içerisine bir dosya kaydetti ancak benim sayfamın sadece ilk satır bilgileri var ,yanlış bir şey yapmış olabilirmiyim

Excel dosyanızda sayfa isimlerinin bulunduğu en alt kısım var oradaki sayfa ismine mausenin sağ tuşuna basın, açılan listeden "Kod Görüntüle" seçin açılan kod sayfasına 2. mesajda yazmış olduğum kodları kopyalayın. Kopyaladığınız kodlardan her hangi bir satır seçiliyken F5 tuşuna basarak kodların çalışmasını sağlayın ve işlemin tamamlanmasını bekleyin.

bmutlu966 · 5 Mayıs 2020

Bir modüle aşağıdaki kodu kopyalayıp makroyu resimdeki gibi bir tuşa atayın. Datanızın başlık satırı 2. satırda olmalı ve datanız A kolonundan
başlamalı. Kaç kolon olduğu önemli değil.

Kod:

Sub Dosyalara_böl()

    Dim t As Long
    Dim Sonsatir As Long
    Dim s As Integer
 
    satirböl = InputBox("Datayi kacar satira bölmek istiyorsunuz?")
   
  Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
    Sonsatir = ThisWorkbook.ActiveSheet.[A1000000].End(3).Row

    For t = 3 To Sonsatir Step satirböl
        Workbooks.Add
        ThisWorkbook.ActiveSheet.Rows("2:2").Copy ActiveWorkbook.ActiveSheet.Range("A1")
        ThisWorkbook.ActiveSheet.Rows(t & ":" & satirböl + t - 1).Copy ActiveWorkbook.ActiveSheet.Rows(2 & ":" & satirböl)
        s = s + 1
       ActiveWorkbook.SaveAs Filename:=s & ".xlsx", _
    FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
    Next
 
     Application.ScreenUpdating = True
    Application.DisplayAlerts = True
 
    MsgBox "İslem tamamlandi."
End Sub

metin_0606 · 5 Mayıs 2020

bmutlu966' Alıntı:

Bir modüle aşağıdaki kodu kopyalayıp makroyu resimdeki gibi bir tuşa atayın. Datanızın başlık satırı 2. satırda olmalı ve datanız A kolonundan
başlamalı. Kaç kolon olduğu önemli değil.

Kod:

Sub Dosyalara_böl()

    Dim t As Long
    Dim Sonsatir As Long
    Dim s As Integer

    satirböl = InputBox("Datayi kacar satira bölmek istiyorsunuz?")
  
  Application.ScreenUpdating = False
Application.DisplayAlerts = False

    Sonsatir = ThisWorkbook.ActiveSheet.[A1000000].End(3).Row

    For t = 3 To Sonsatir Step satirböl
        Workbooks.Add
        ThisWorkbook.ActiveSheet.Rows("2:2").Copy ActiveWorkbook.ActiveSheet.Range("A1")
        ThisWorkbook.ActiveSheet.Rows(t & ":" & satirböl + t - 1).Copy ActiveWorkbook.ActiveSheet.Rows(2 & ":" & satirböl)
        s = s + 1
       ActiveWorkbook.SaveAs Filename:=s & ".xlsx", _
    FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
    Next

     Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    MsgBox "İslem tamamlandi."
End Sub

Ekli dosyayı görüntüle 217516

Dediğiniz gibi yapıyorum ama maalesef önceki dediğim gibi oluyor.

metin_0606 · 5 Mayıs 2020

bmutlu966' Alıntı:

Bir modüle aşağıdaki kodu kopyalayıp makroyu resimdeki gibi bir tuşa atayın. Datanızın başlık satırı 2. satırda olmalı ve datanız A kolonundan
başlamalı. Kaç kolon olduğu önemli değil.

Kod:

Sub Dosyalara_böl()

    Dim t As Long
    Dim Sonsatir As Long
    Dim s As Integer

    satirböl = InputBox("Datayi kacar satira bölmek istiyorsunuz?")
  
  Application.ScreenUpdating = False
Application.DisplayAlerts = False

    Sonsatir = ThisWorkbook.ActiveSheet.[A1000000].End(3).Row

    For t = 3 To Sonsatir Step satirböl
        Workbooks.Add
        ThisWorkbook.ActiveSheet.Rows("2:2").Copy ActiveWorkbook.ActiveSheet.Range("A1")
        ThisWorkbook.ActiveSheet.Rows(t & ":" & satirböl + t - 1).Copy ActiveWorkbook.ActiveSheet.Rows(2 & ":" & satirböl)
        s = s + 1
       ActiveWorkbook.SaveAs Filename:=s & ".xlsx", _
    FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
    Next

     Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    MsgBox "İslem tamamlandi."
End Sub

Ekli dosyayı görüntüle 217516

Aynen dediğiniz gibi yapıyorum son paylaşmış olduğunuz makroyu butona atayıp çalıştırıyorum ama tamamlandı diyor ama işlem yapmıyor

bmutlu966 · 5 Mayıs 2020

Sizin dosyanız hangi formatta, makro kaydettiğiniz dosyayı .xlsm olarak kaydedip denediniz mi?

metin_0606 · 5 Mayıs 2020

bmutlu966' Alıntı:
Sizin dosyanız hangi formatta, makro kaydettiğiniz dosyayı .xlsm olarak kaydedip denediniz mi?

Evet sizin yukarıda paylaşmış olduğunuz xlsm uzantılı dosyada deniyorum zaten

bmutlu966 · 5 Mayıs 2020

Dosya bende çalışıyor. Dosyayı değiştirip tekrar yüklüyorum. Bu dosyayı dener misiniz?

metin_0606 · 5 Mayıs 2020

bmutlu966' Alıntı:
Dosya bende çalışıyor. Dosyayı değiştirip tekrar yüklüyorum. Bu dosyayı dener misiniz?

Çalışıyor ama işlem yapmıyor sanırım ayarlarda bir şeyler var

7000 bin satırlı excel dosyamı 120 satırlı dosyalar haline getirebilir miyim?

konsilyer

Muzaffer Ali

Destek Ekibi

kulomer46

Ekli dosyalar

konsilyer

kulomer46

Ekli dosyalar

bmutlu966

Ekli dosyalar

konsilyer

kulomer46

konsilyer

kulomer46

metin_0606

metin_0606

Muzaffer Ali

Destek Ekibi

bmutlu966

metin_0606

metin_0606

Ekli dosyalar

bmutlu966

metin_0606

bmutlu966

Ekli dosyalar

metin_0606