Excel to txt

[yyhy]

Excelde kayıt ettiğim dataları d sürücüsü içerisine txt dosyası olarak kayıt etme konusunda elimde yine Excel Web Tr den aldığım yardımcı dosya ve kodlarla bir çalışma sayfası oluşturdum. Dosyada yapmak istediğim txt dosyasına veriler aktarılıyor yalnız verilerin hizalı olmasını istiyorum. Acaba verileri hizalı yapmak için bu dosya veya başka bir önerisi olan var mı? Şimdiden teşekkür ederim.

 

[ÖmerBey]

Merhaba,
FileFormat seçeneğini xlText yapıp deneyiniz. Aynı işlemi excel farklı kaydet menüsünden Metin (Sekmeyle ayrılmış) seçeneğiyle de yapabilirsiniz.
iyi çalışmalar...

 

[Zeki Gürsoy]

Bunu "SaveAs" metodu yerine dosyalama metodunu kullanarak yapabilirsiniz. Dosyalama metodunu kullanmadan önce de, kolonlar için sabit uzunluklar belirlenmelidir.

Sub Test()
    Dim i, c1, c2, c3, c4, c5, c6, c7
    
    Open ThisWorkbook.Path & "\Demo.txt" For Output As #1
    
    For i = 1 To [b1000].End(3).Row
    
        c1 = Format(Cells(i, "b"), "!" & String(5, "@")) & " "
        c2 = Format(Cells(i, "c"), "!" & String(20, "@")) & " "
        c3 = Format(Cells(i, "d"), "!" & String(20, "@")) & " "
        c4 = Format(Cells(i, "e"), "!" & String(5, "@")) & " "
        c5 = Format(Cells(i, "f"), "!" & String(6, "@")) & " "
        c6 = Format(Cells(i, "g"), "!" & String(6, "@")) & " "
        c7 = Format(Cells(i, "h"), "!" & String(6, "@")) & " "
        
        Print #1, c1; c2; c3; c4; c5; c6; c7
        
    Next
    
    Close #1
    
End Sub

.

 

[yyhy]

Öncelikle arkadaşlara teşekkür ederim. Ömer beyin yazmış olduğunu tam anlayamadım. Biraz açıklık getirebilir misiniz? Zeki Gürsoy kodlar işlemi istediğim gibi yapıyor ama uzunluk belirtilmeden kodlarda değişiklik yapılabilir mi?

 

[Zeki Gürsoy]

Öngörülen bir uzunluk belirlemek zorundasınız. Ömer Bey'in önerisi "TAB" ile boşlık verebilir ancak aynı hizada olmayacaktır.

.

 

[ÖmerBey]

Öngörülen bir uzunluk belirlemek zorundasınız. Ömer Bey'in önerisi "TAB" ile boşlık verebilir ancak aynı hizada olmayacaktır.

Zeki Bey haklı, ben de durumu sonradan farkettim. Tab ile çözüm arıyordum, aşağıdaki gibi bir sonuca ulaştım. Alternatif olsun...

Sub kod()
ts = InputBox("Dosya Adı Girişi", "Dosya Adı Giriş")
If ts = "" Then Exit Sub
Open "D:\" & ts & ".txt" For Output As #1
For a = 1 To Range("B65500").End(3).Row
    For b = 2 To 8
        If b = 3 Or b = 4 Then
            If Len(Cells(a, b).Text) < 8 Then
                yaz = yaz & Cells(a, b).Text & vbTab & vbTab & vbTab
            ElseIf Len(Cells(a, b).Text) < 16 Then
                yaz = yaz & Cells(a, b).Text & vbTab & vbTab
            Else
                yaz = yaz & Cells(a, b).Text & vbTab
            End If
        Else
            yaz = yaz & Cells(a, b).Text & vbTab
        End If
    Next
    Print #1, yaz
    yaz = Empty
Next
Close #1
End Sub

 

[halit3]

Alternatif olması açısından
farklı bir uygulama

Sub deneme()
Dim i, j, ara, yaz
Open ThisWorkbook.Path & "\Dem.txt" For Output As #1

ara = "                                                                   "

For i = 1 To Cells(Rows.Count, "B").End(3).Row
yaz = ""
For j = 2 To 8
yaz = yaz & Left(Cells(i, j) & ara, 20)
Next j
Print #1, yaz
Next
Close #1

End Sub

Sub deneme()
Dim i, j, yaz
Dim ara(8) As String * 20
Open ThisWorkbook.Path & "\Dem.txt" For Output As #1
For i = 1 To Cells(Rows.Count, "B").End(3).Row
yaz = ""
For j = 2 To 8
ara(j) = Cells(i, j)
yaz = yaz & ara(j)
Next j
Print #1, yaz
Next
Close #1
End Sub

 

[Korhan Ayhan]

Bir alternatifte ben sunayım.

Kod sütunlardaki maksimum uzunluğa göre "txt" dosyası oluşturuyor.

Option Explicit

Sub Txt_Dosyasi_Olustur()
    Dim Dosya_Sistemi As Object, Txt_Dosyasi, Dosya_Adi As String
    Dim Son As Long, X As Long, Y As Byte, Veri As String
    Dim Alan As String, Maksimum As Long
    
    Dosya_Adi = InputBox("Dosya adı giriniz...", "Dosya Adı Girişi")
    If Dosya_Adi = "" Then Exit Sub
    
    Set Dosya_Sistemi = CreateObject("Scripting.FileSystemObject")
    Set Txt_Dosyasi = Dosya_Sistemi.CreateTextFile("C:\Users\KORHAN\Desktop\" & Dosya_Adi & ".txt", True)
    
    Son = Cells(Rows.Count, 2).End(3).Row
    
    For X = 1 To Son
        For Y = 2 To 8
            Alan = Range(Cells(1, Y), Cells(Son, Y)).Address
            Maksimum = Evaluate("=MAX(LEN(" & Alan & "))")
            
            If Veri = "" Then
                Veri = Cells(X, Y) & WorksheetFunction.Rept(" ", Maksimum - Len(Cells(X, Y))) & vbTab
            Else
                Veri = Veri & Cells(X, Y) & WorksheetFunction.Rept(" ", Maksimum - Len(Cells(X, Y))) & IIf(Y = 8, "", vbTab)
            End If
        Next
        
        Txt_Dosyasi.WriteLine Trim(Veri)
        Veri = Empty
    Next
        
    Txt_Dosyasi.Close
    
    MsgBox "TXT dosyası oluşturulmuştur.", vbInformation
End Sub

 

[Tevfik_Kursun]

Muhterem Arkadaşlar,
Alternatifler için ben de teşekkür ederim.
Saygılarımla

 

[Haluk]

Bir alternatif de ben vermiş olayım....

Gerçi, pek alternatif sayılmaz..... yukarıda Zeki Beyin önerdiği koddan çok farklı değil.

Sadece, hücrelerdeki verileri aktardığımız değişkenlerin Text dosyasında kaplayacakları alanları, kodun başında tarif ediyoruz.

Sub Test2()
    Dim Sira As String * 5
    Dim Ad As String * 20
    Dim Soyad As String * 20
    Dim No As String * 5
    Dim Bilgi1 As String * 20
    Dim Bilgi2 As String * 20
    Dim Bilgi3 As String * 20

    Open ThisWorkbook.Path & "\Demo2.txt" For Output As #1
    
    For i = 1 To Range("B" & Rows.Count).End(3).Row
        Sira = Range("B" & i)
        Ad = Range("C" & i)
        Soyad = Range("D" & i)
        No = Range("E" & i)
        Bilgi1 = Range("F" & i)
        Bilgi2 = Range("G" & i)
        Bilgi3 = Range("H" & i)

        Print #1, Sira; Ad; Soyad; No; Bilgi1; Bilgi2; Bilgi3
    Next
    
    Close #1
End Sub

 

[Murat OSMA]

Alternatif;

[SIZE="2"]Sub Emre()
    Open ThisWorkbook.Path & "\Demo.txt" For Output As #1
    For i = 1 To [a65536].End(3).Row
        alan1 = Hizala(Cells(i, 1).Value, " ", 5)
        alan2 = Hizala(Cells(i, 2).Value, " ", 20)
        alan3 = Hizala(Cells(i, 3).Value, " ", 20)
        alan4 = Hizala(Cells(i, 4).Value, " ", 5)
        alan5 = Hizala(Cells(i, 5).Value, " ", 20)
        alan6 = Hizala(Cells(i, 6).Value, " ", 20)
        alan7 = Hizala(Cells(i, 7).Value, " ", 20)
        Print #1, alan1 & alan2 & alan3 & alan4 & alan5 & alan6 & alan7
    Next i
    Close #1
End Sub

Function Hizala(ByVal metin As String, kar As String, uz As Integer) As String
    metin = Trim(metin): uzun = Len(metin)
    If uzun < uz Then
        metin = metin + String(uz - uzun, kar)
            Else
        metin = Mid$(metin, 1, uz)
    End If
    Hizala = metin
End Function[/SIZE]

 

[yyhy]

Sayın excel.web.tr ailesine...

Konuyu açan, okuyan, ilgilenip zaman ayırıp cevap yazan tüm excel.web.tr ailesine teşekkürler.
Ayrıca Sayın Murat OSMA bey sizin eklemiş olduğunuz kodu örnek sayfada uygulayamadım, zahmet olmaz ise acaba örnek dosyaya uygulayıp ekleyebilir misiniz?

 

[yyhy]

Sayın Murat OSMA bey sizin eklemiş olduğunuz kodu örnek sayfada uygulayamadım, zahmet olmaz ise acaba örnek dosyaya uygulayıp ekleyebilir misiniz?