• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Excel den .txt (Metin Belgesi) dosyasına kayıt

  • Konbuyu başlatan Konbuyu başlatan asas44
  • Başlangıç tarihi Başlangıç tarihi
A

asas44

Katılım
13 Temmuz 2013
Mesajlar
121
Excel Vers. ve Dili
2013 excel
Elimdeki excel dosyasında binlerce satır veri var, her 900 satırı bir .txt (Metin Belgesi) dosyasına kaydetmek istiyorum. Örneğin ilk 900 satırı 1. .txt (Metin Belgesi) dosyasına arkasından gelen ikinci 900 satırı 2. .txt (Metin Belgesi) dosyasına arkasından gelen üçüncü 900 satırı 3. .txt (Metin Belgesi) dosyasına ..... kaydedecek bu .txt (Metin Belgesi) dosyalarını kendi açıp yazıp kaydedecek mümkünmüdür acaba ?
 
. . .

Bir kaç satırlık excel ve txt dosyası örneği yükleyebilir misiniz.

. . .
 
Emir Hüseyin bey exceldeki ilk 900 satırı alıp 1 tane metin belgesi açıp içine kaydedip kapatacak sonra o aldığı 900 satırdan sonraki gelen 1800 satırın kalan 900 satırını alıp 2. metin belgesini açıp içine kaydedip çıkacak bu mantıkta son veriye kadar inecek diyelim 90.300 satırlık bir excelde 90 tane metin belgesi açarak kayıt yaptı son 300 satırıda alıp son metin belgesine kaydedip çıkacak ve işlemi bitirecek. (Exceldeki sütun sayısı farketmez 2 sütundanda oluşabilir veri, 5 sütundanda, 1 sütundanda)
Örnek dosya: https://drive.google.com/open?id=0B6EbKfe08n2gSDRlcWkydkEwc0U
 
.

Excel listede
Arada boş satır olabilir mi.

.
 
Merhaba.

Sayın ÇOBAN'ın müsadeleriyle. Hazırlamıştım, göndereyim dedim.

Aşağıdaki kod'u kullanabilirsiniz.

Kod excel belgesinin bulunduğu klasöre, 900 satırlık herbir bölümü bir txt olarak kaydeder.

-- Verinizin sütun sayısına göre kırmızı işaretlediğim kısma benzer şekilde gerekli ilaveyi yapın.
-- dosya adının başlangıç kısmını, isteğinize göre değiştirin,
-- kod, oluşturulan txt belgeyi, vereceğiniz bu ismin sonuna 1, 2, 3 ... gibi sayı ekleyerek adlandırır.
.
Kod: 
[B]Sub txt_BRN()[/B]
Set s1 = Sheets("Sayfa1"): s1.Activate
yol = ThisWorkbook.Path & "\": adı = "[B][COLOR="Blue"]asas44_BRN_[/COLOR][/B]"
adet = WorksheetFunction.RoundUp(s1.Cells(Rows.Count, 1).End(3).Row / 900, 0)
For brn = 1 To adet
    sayı = sayı + 1: ilk = (brn - 1) * 900 + 1: son = ilk + 899
    If son > s1.Cells(Rows.Count, 1).End(3).Row Then son = s1.Cells(Rows.Count, 1).End(3).Row
        Open yol & adı & sayı & ".txt" For Output As #1
            For i = ilk To son
                Print #1, Cells(i, "A")[B][COLOR="Red"]; vbTab; Cells(i, "B")[/COLOR][/B]
            Next i
        Close #1
Next
MsgBox "Bu belgenin bulunduğu klasöre, gerekli TXT belgeler oluşturuldu. ", , "..::.. Ö. BARAN ..::.."
[B]End Sub[/B]
 
Alternatif kod

Kod: 
Sub deneme()
son = 900
say = 0
For i = 1 To Cells(Rows.Count, "B").End(3).Row
yaz = ""
For j = 1 To Cells(i, Columns.Count).End(xlToLeft).Column ' yan sütün sayısı
yaz = yaz & RightPadChar(Cells(i, j), " ", 8) 'boşlu sayısı
Next j

If say = son Or say = 0 Then
sayi = CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).Files.Count 'klasördeki dosya sayısı
kayit = ThisWorkbook.Path & "\dosya" & sayi & ".txt"
say = 0
'Open kayit For Output As #1
Open kayit For Append As #1
End If

Print #1, yaz

If say = son - 1 Then
Close #1
End If

say = say + 1
Next i
Close #1
MsgBox "işlem tamam"
End Sub

Function RightPadChar(ByVal Astr As String, PadChar As String, stLen As Integer) As String
Dim AStrL As Integer
Astr = Trim(Astr)
AStrL = Len(Astr)
If AStrL < stLen Then
Astr = Astr + String(stLen - AStrL, PadChar)
Else
Astr = Mid$(Astr, 1, stLen)
End If
RightPadChar = Astr
End Function
 
Ömer Hocam elinize sağlık Halit hocam şimdi gördüm sizin koduda emeklerinize sağlık
 
asas44' Alıntı:
Elimdeki excel dosyasında binlerce satır veri var, her 900 satırı bir .txt (Metin Belgesi) dosyasına kaydetmek istiyorum. Örneğin ilk 900 satırı 1. .txt (Metin Belgesi) dosyasına arkasından gelen ikinci 900 satırı 2. .txt (Metin Belgesi) dosyasına arkasından gelen üçüncü 900 satırı 3. .txt (Metin Belgesi) dosyasına ..... kaydedecek bu .txt (Metin Belgesi) dosyalarını kendi açıp yazıp kaydedecek mümkünmüdür acaba ?
Genişletmek için tıkla ...

Mümkündür.
dosyanı gönder yardım edeyim.
 
Ömer BARAN' Alıntı:
Merhaba.

Sayın ÇOBAN'ın müsadeleriyle. Hazırlamıştım, göndereyim dedim.

Aşağıdaki kod'u kullanabilirsiniz.

Kod excel belgesinin bulunduğu klasöre, 900 satırlık herbir bölümü bir txt olarak kaydeder.

-- Verinizin sütun sayısına göre kırmızı işaretlediğim kısma benzer şekilde gerekli ilaveyi yapın.
-- dosya adının başlangıç kısmını, isteğinize göre değiştirin,
-- kod, oluşturulan txt belgeyi, vereceğiniz bu ismin sonuna 1, 2, 3 ... gibi sayı ekleyerek adlandırır.
.
Kod: 
[B]Sub txt_BRN()[/B]
Set s1 = Sheets("Sayfa1"): s1.Activate
yol = ThisWorkbook.Path & "\": adı = "[B][COLOR="Blue"]asas44_BRN_[/COLOR][/B]"
adet = WorksheetFunction.RoundUp(s1.Cells(Rows.Count, 1).End(3).Row / 900, 0)
For brn = 1 To adet
    sayı = sayı + 1: ilk = (brn - 1) * 900 + 1: son = ilk + 899
    If son > s1.Cells(Rows.Count, 1).End(3).Row Then son = s1.Cells(Rows.Count, 1).End(3).Row
        Open yol & adı & sayı & ".txt" For Output As #1
            For i = ilk To son
                Print #1, Cells(i, "A")[B][COLOR="Red"]; vbTab; Cells(i, "B")[/COLOR][/B]
            Next i
        Close #1
Next
MsgBox "Bu belgenin bulunduğu klasöre, gerekli TXT belgeler oluşturuldu. ", , "..::.. Ö. BARAN ..::.."
[B]End Sub[/B]
Genişletmek için tıkla ...

Hocam göndermiş olduğunuz macro yu çalıştırıyorum dosyadaki verileri .txt dosyalarına parçalıyor doğru bir şekilde fakat .txt dosyalarına girdiğim zaman verilerin başına ve sonuna boşluklar bırakıyor. Boşluk sorunuda kalkarsa tam süper olacak. Şimdiden elinize sağlık
https://www.dosyaupload.com/hWSX
 
asas44' Alıntı:
Hocam göndermiş olduğunuz macro yu çalıştırıyorum dosyadaki verileri .txt dosyalarına parçalıyor doğru bir şekilde fakat .txt dosyalarına girdiğim zaman verilerin başına ve sonuna boşluklar bırakıyor. Boşluk sorunuda kalkarsa tam süper olacak. Şimdiden elinize sağlık
https://www.dosyaupload.com/hWSX
Genişletmek için tıkla ...


Birde bu kodu denermisiniz.

Kod: 
Sub deneme()
son = 900
say = 0
For i = 1 To Cells(Rows.Count, "[COLOR="Red"]a[/COLOR]").End(3).Row
yaz = ""
For j = 1 To Cells(i, Columns.Count).End(xlToLeft).Column ' yan sütün sayısı
yaz = yaz & RightPadChar(Cells(i, j), " ", [COLOR="Red"]11[/COLOR]) 'boşlu sayısı
Next j

If say = son Or say = 0 Then
sayi = CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).Files.Count 'klasördeki dosya sayısı
kayit = ThisWorkbook.Path & "\dosya" & sayi & ".txt"
say = 0
'Open kayit For Output As #1
Open kayit For Append As #1
End If

Print #1, yaz

If say = son - 1 Then
Close #1
End If

say = say + 1
Next i
Close #1
MsgBox "işlem tamam"
End Sub
 
kodun diğer bölümünü eklememişim kodun tamamı bu

Kod: 
Sub deneme()
son = 900
say = 0
For i = 1 To Cells(Rows.Count, "a").End(3).Row
yaz = ""
For j = 1 To Cells(i, Columns.Count).End(xlToLeft).Column ' yan sütün sayısı
yaz = yaz & RightPadChar(Cells(i, j), " ", 11) 'boşlu sayısı
Next j

If say = son Or say = 0 Then
sayi = CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).Files.Count 'klasördeki dosya sayısı
kayit = ThisWorkbook.Path & "\dosya" & sayi & ".txt"
say = 0
'Open kayit For Output As #1
Open kayit For Append As #1
End If

Print #1, yaz

If say = son - 1 Then
Close #1
End If

say = say + 1
Next i
Close #1
MsgBox "işlem tamam"
End Sub


[COLOR="Red"]Function RightPadChar(ByVal Astr As String, PadChar As String, stLen As Integer) As String
Dim AStrL As Integer
Astr = Trim(Astr)
AStrL = Len(Astr)
If AStrL < stLen Then
Astr = Astr + String(stLen - AStrL, PadChar)
Else
Astr = Mid$(Astr, 1, stLen)
End If
RightPadChar = Astr
End Function[/COLOR]
 
sadece tek sutün yazdıracaksanız kod

Kod: 
Sub deneme()
son = 900
say = 0
For i = 1 To Cells(Rows.Count, "a").End(3).Row

If say = son Or say = 0 Then
sayi = CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).Files.Count 'klasördeki dosya sayısı
kayit = ThisWorkbook.Path & "\dosya" & sayi & ".txt"
say = 0
Open kayit For Append As #1
End If
Print #1, Mid(Cells(i, 1), 1, Len(Cells(i, 1)))

If say = son - 1 Then
Close #1
End If
say = say + 1
Next i
Close #1
MsgBox "işlem tamam"
End Sub
 
Halit3 hocam çok teşekkürler elinize sağlık gayet iyi çalışıyor şuan
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst