DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Merhaba
Teşekkürler sayın kulomer tam istediğim gibi oldu
Selamlar...
Rica etsem daha önce yazdığınız koda , bölünen her dosyada başlık satırı a1 in yer almasını sağlayacak eklemeyi yapar mısınız?
Option Explicit
Sub Verileri_Bolerek_CSV_Dosyasi_Olarak_Kaydet()
Dim Satir_Adedi As Long, Veri As Variant, Son As Long, Dosya_Adedi As Long
Dim X As Long, Y As Long, Z As Byte, Say As Long, CSV_File As Variant, 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 = 2 Then Son = 3
Veri = Range("A2:K" & Son).Value
If Dir(ThisWorkbook.Path & "\*.csv") <> "" Then Kill ThisWorkbook.Path & "\*.csv"
For X = LBound(Veri) To UBound(Veri)
Dosya_Adedi = Dosya_Adedi + 1
Set CSV_File = CreateObject("Scripting.FileSystemObject").CreateTextFile(ThisWorkbook.Path & "\Dosya_" & Dosya_Adedi & ".csv", True)
For Y = X To X + Satir_Adedi
If Y > UBound(Veri) Then GoTo 10
ReDim Liste(1 To 11)
For Z = 1 To 11
Say = Say + 1
Liste(Say) = Veri(Y, Z)
Next
CSV_File.WriteLine Join(Liste, ",")
Erase Liste
Say = 0
Next
10 CSV_File.Close
X = Y - 1
Next
MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End SubKill ThisWorkbook.Path & "\*.csv"
Teşekkür ederim çok hızlı şekilde csv ye çevirdi ancak benim bunları aldığım kaynak dosyadaki 1 satırdaki 11 sutün olan başlığı her bir 120 lik dosyada başlık olarak konumlandırmam lazım , çünkü dosyayı yüklediğim yer başlık satırını istiyor, bu konuda yardımcı olabilirmisiniz
bir problem daha var , kulomer46 nın kodunda csv yapınca ayrı ayrı sütunlar da görüntüleniyordu, bunları yüklediğim sistem hata vermiyordu, ama sizin kod da bunlar tek sütun içerisinde görünüyor yüklediğim sistem geri kalan 10 sütun boş gibi bir uyarı veriyor, sanırım klomer46 nın koduna 1 satırdaki yani başlık satırının her 120 lik dosyaya kopyalanmasını sağlarsak eğer problem çözülecek, yardımı emeği geçenlere şimdiden çok teşekkür ederim.
Yardımınız için teşekkür ederim tekrar
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"
K1.Close 1
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
Sub texteAktar()
ayrac = ","
'ayrac = ";"
'ayrac = vbTab
Zaman = Timer
FullPath = ThisWorkbook.Path & Application.PathSeparator
If Dir(FullPath & "*.csv") <> "" Then Kill FullPath & "*.csv"
baslik = Join(Application.Index(Range("A1:K1").Value, 1, 0), ayrac)
Son = Cells(Rows.Count, 1).End(3).Row
Set clipboard = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
With CreateObject("Scripting.FileSystemObject")
For i = 2 To Son Step 119
sonSat = i + 118
If sonSat > Son Then sonSat = Son
dosya = dosya + 1
Range(Cells(i, "A"), Cells(sonSat, "K")).Copy
With .CreateTextFile(FullPath & "text" & dosya & ".csv", True)
.WriteLine baslik
clipboard.GetFromClipboard
al = clipboard.Gettext
al = Left(al, Len(al) - 2)
.WriteLine Replace(al, vbTab, ayrac) 'ayrac tabdan farklıysa burası aktif olacak
'.WriteLine al 'ayrac tab ise burası aktif olacak
.Close
End With
Next i
End With
Set clipboard = Nothing
MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Subİlginiz için çok teşekkür ederim, şöyle bir hata aldım