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

[konsilyer]

AVDxwN.png

CSV

hizliresim.com

Daha önceki kodlarda sadece a1 içerisine virgülle ayırılmış şekilde geliyordu veriler ama, bunu yüklediğim sistem bunu istemiyor sanırım, her birisini ayrı sütunlar halinde istiyor, a1 de olduğu zaman 11 sütun luk veriyi 1 sütun veya 3 sütun olarak algılıyor

 

[Korhan Ayhan]

Yani benim kod ile oluşturduğum dosyayı açıp CSV virgülle ayrılmış olarak kayıt ettiğinizde sizde sonuç olarak verilerin ayrı sütunlarda göründüğü bir CSV dosyası mı oluşuyor?

 

[konsilyer]

aynen öyle, ki bana lazım olan da o şekilde

 

[konsilyer]

Merhaba

Aktif sayfayı kullanıcının belirlediği satır adedine göre başlık kısmınıda kopyalayıp yeni sıfır dosyalara dağıtan program Ek 'tedir.

Selamlar...

Altın üye olup dosyasını indirip denedim sayın kulomer46,
makrodaki oluşturulacak dosya uzantısı olan xlsx yerine csv yazdım, bana csv lazım, csv olarak kayıt yapıyor ancak excel ile açtığım da
"dosyanın biçimi ve uzantısı eşleşmiyor. Dosya bozulmuş olabilir" uyarısı alıyorum, dosyayı hiç açmadan csv olarak yüklemeye çalıştığım zaman oluşan dosyayı tek sütunlu algılıyor yüklediğim yer.
Benden istenen format 11 sütunlu virgülle ayrılmış csv.
Oluşan excel dosyalarını kendim CSV olarak kayıt edersem 11 sütunlu bir csv olarak kayıt ediyor ama bu makroyu kullandığım zaman tek sütunlu bir csv dosyası oluşturuyor.
Ben şu an ki durumda yaklaşık 90 excel dosyasını tek tek açıp virgülle ayrılmış csv olarak kayıt ediyorum.
Bilemiyorum yardımcı olunabilinecek bir durum var mıdır. Şimdiden teşekkürler yazan herkese.

 

[Korhan Ayhan]

Deneyiniz.

7.000 satırlı bir dosyada işlem bende yaklaşık 25 saniye sürüyor.

Option Explicit

Sub Verileri_Bolerek_CSV_Dosyasi_Olarak_Kaydet()
    Dim Satir_Adedi As Long, Veri As Variant, Son As Long
    Dim Dosya_Adedi As Long, XL_App As Object, K1 As Object, S1 As Object
    Dim X As Long, Y As Long, Z As Byte, Say As Long, Zaman As Double
    
    Satir_Adedi = Application.InputBox("Verinizi kaç satırlık dosyalara bölmek istiyor sunuz?", "Satır Sayısı", 120, , , , , 1)
    
    If Satir_Adedi = 0 Then
        MsgBox "Lütfen geçerli bir sayısal değer giriniz!", vbCritical
        Exit Sub
    End If
    
    Zaman = Timer
    
    Son = Cells(Rows.Count, 1).End(3).Row
    If Son = 1 Then Son = 2
    
    Veri = Range("A1:K" & Son).Value
    
    If Dir(ThisWorkbook.Path & "\*.csv") <> "" Then Kill ThisWorkbook.Path & "\*.csv"
    
    Set XL_App = CreateObject("Excel.Application")
    XL_App.Visible = False
    XL_App.DisplayAlerts = False
    
    For X = LBound(Veri) + 1 To UBound(Veri) Step Satir_Adedi
        Dosya_Adedi = Dosya_Adedi + 1
        
        Set K1 = XL_App.Workbooks.Add(1)
        Set S1 = K1.Sheets(1)
        
        ReDim Liste(1 To 121, 1 To 11)
        
        Say = Say + 1
        
        For Z = 1 To 11
            Liste(Say, Z) = Veri(1, Z)
        Next
                
        For Y = X To X + Satir_Adedi - 1
            If Y > UBound(Veri) Then GoTo 10
            
            Say = Say + 1
            
            For Z = 1 To 11
                Liste(Say, Z) = Veri(Y, Z)
            Next
        Next

10      S1.Range("A1").Resize(Say, 11) = Liste
        S1.Columns.AutoFit

        Erase Liste
        Say = 0
    
        K1.SaveAs ThisWorkbook.Path & "\Dosya_" & Dosya_Adedi & ".csv"
        K1.Close 1
        
        Set K1 = XL_App.Workbooks.Open(Filename:=ThisWorkbook.Path & "\Dosya_" & Dosya_Adedi & ".csv")
        K1.SaveAs Filename:=ThisWorkbook.Path & "\Dosya_" & Dosya_Adedi & ".csv", FileFormat:=xlCSV, CreateBackup:=False
        K1.Close 1
    Next
        
    XL_App.DisplayAlerts = True
    
    Set S1 = Nothing
    Set K1 = Nothing
    Set XL_App = Nothing
    
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[konsilyer]

Deneyiniz.

7.000 satırlı bir dosyada işlem bende yaklaşık 25 saniye sürüyor.

İlginiz için tekrar çok teşekkür ederim baya vaktinizi aldım.

csv haklısınız virgülle ayrılmış şekilde ancak neden bilemiyorum, her birisi ayrı sütunlarda olmadan yükleme yapamıyorum. Ama dosyaları açarken yaşanan problem ortadan kalktı. Mesela sizin kod ile çıkan sonucu metni tabloya dönüştür dedim, o şekilde yükledim kabul etti. Bu sefer de 100 dosyada aynı şeyi yapmam gerekli.

 

[Korhan Ayhan]

@konsilyer,

120 satırlık verilere bölünen dosyaları FileFormat belirtmeden kayıt ettiğimde bende 11 sütunlu dosya oluşuyor. Fakat oluşan dosyayı açmak istediğimde aşağıdaki hata ekranı ile karşılaşıyorum.



EVET diyerek açmaya devam ediyorum. Dosya açılıyor. 11 sütunlu bir dosya görüyorum.

Sizin #39 nolu mesajınızdaki tarif ettiğiniz yöntemle farklı kaydet yaparak resimdeki seçimi yaparak kaydet diyorum.



Aşağıdaki uyarıyı veriyor.



Bu uyarıya da EVET diyorum.

Bu sefer aşağıdaki uyarıyı veriyor.



Bu uyarıya da EVET diyerek işleme devam ediyorum

Bu işlemlerden sonra köşedeki çarpıdan açık olan dosyayı kapatmak istediğimde aşağıdaki uyarıyı tekrar veriyor.



KAYDET diyerek işleme devam ediyorum.

FARKLI KAYDET ekranı tekrar geliyor. Bu ekranda KAYDET dediğimde "Varolan dosyayı değiştirmek istiyor musunuz?" uyarısı geliyor. EVET dediğimde 4. resimdeki uyarı tekrar geliyor. Buna yine EVET diyerek devam ettiğimde dosya nihayet kapanıyor.

Size son önerdiğim kod ile bende bu işlemi yapmaya çalıştım. Ama sanırım kod ile bu durum oluşmuyor. Ya da atladığımız bir nokta var.

Peki hiç bu işlemi yapmamış olsaydık. Yani benim #37 nolu mesajımda önerdiğim kod ile oluşan CSV dosyasını açmadığınızda sisteminiz 11 sütunlu bu dosyayı kabul ediyor mu?

 

[Korhan Ayhan]

Birazcık araştırma yaptım. Sanırım aşağıdaki şekilde işinizi görecektir.

Deneyip sonucu bildirir misiniz?

Bende işlem 13 saniye civarında tamamlanıyor.

Option Explicit

Sub Verileri_Bolerek_CSV_Dosyasi_Olarak_Kaydet()
    Dim Satir_Adedi As Long, Veri As Variant, Son As Long
    Dim Dosya_Adedi As Long, XL_App As Object, K1 As Object, S1 As Object
    Dim X As Long, Y As Long, Z As Byte, Say As Long, Zaman As Double
    
    Satir_Adedi = Application.InputBox("Verinizi kaç satırlık dosyalara bölmek istiyor sunuz?", "Satır Sayısı", 120, , , , , 1)
    
    If Satir_Adedi = 0 Then
        MsgBox "Lütfen geçerli bir sayısal değer giriniz!", vbCritical
        Exit Sub
    End If
    
    Zaman = Timer
    
    Son = Cells(Rows.Count, 1).End(3).Row
    If Son = 1 Then Son = 2
    
    Veri = Range("A1:K" & Son).Value
    
    If Dir(ThisWorkbook.Path & "\*.csv") <> "" Then Kill ThisWorkbook.Path & "\*.csv"
    
    Set XL_App = CreateObject("Excel.Application")
    XL_App.Visible = False
    
    For X = LBound(Veri) + 1 To UBound(Veri) Step Satir_Adedi
        Dosya_Adedi = Dosya_Adedi + 1
        
        Set K1 = XL_App.Workbooks.Add(1)
        Set S1 = K1.Sheets(1)
        
        ReDim Liste(1 To 121, 1 To 11)
        
        Say = Say + 1
        
        For Z = 1 To 11
            Liste(Say, Z) = Veri(1, Z)
        Next
                
        For Y = X To X + Satir_Adedi - 1
            If Y > UBound(Veri) Then GoTo 10
            
            Say = Say + 1
            
            For Z = 1 To 11
                Liste(Say, Z) = Veri(Y, Z)
            Next
        Next

10      S1.Range("A1").Resize(Say, 11) = Liste
        S1.Columns.AutoFit

        Erase Liste
        Say = 0
    
        K1.SaveAs ThisWorkbook.Path & "\Dosya_" & Dosya_Adedi & ".csv", FileFormat:=xlCSV, Local:=True
        K1.Close 0
    Next
        
    Set S1 = Nothing
    Set K1 = Nothing
    Set XL_App = Nothing
    
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[konsilyer]

Birazcık araştırma yaptım. Sanırım aşağıdaki şekilde işinizi görecektir.

Deneyip sonucu bildirir misiniz?

Bende işlem 13 saniye civarında tamamlanıyor.

Size ne kadar teşekkür etsem azdır, evet bu sefer oldu hiç problemsiz. Tekrar çok teşekkür ederim.

 

[SeviLmeyen]

Merhaba

Aktif sayfayı kullanıcının belirlediği satır adedine göre başlık kısmınıda kopyalayıp yeni sıfır dosyalara dağıtan program Ek 'tedir.

Selamlar...

Kulomer46 Üstat selamlar.

Bu programı revize etme şansınız var mı?
Satır satır ayırmak değilde A3 hücresinden başlayacak şekilde yıl yıl ayırma şansımız var mı acaba?
Yıllar 2009'dan başlıyor. Ne kadar 2009 yazıyorsa o kadar ayırsın ne kadar 2010 yazıyorsa o kadar ayırsın bu yapılabilir mi acaba?

Bu konuda yardımlarınızı bekler, iyi çalışmalar dilerim.
Saygılarımla.

 

[ulutanas]

Sayın bmutlu966 merhaba, son eklemiş olduğunuz dosyaya 1000 satırlık veri ekledim, işlem yapıyor ama nereye kayıt yaptığını bulamadım.

 

[ulutanas]

Korhan Ayhan Hocamın eklediği kodu görmeden yorum yaptım, kod tam olarak çalışıyor.
Teşekkürler hocam benimde işime yaradı bu işlem...

 

[igultekin2000]

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

Merhaba; yapılan bölme işlemi Belgelerim klasörüne gidiyor.