excel dosyasını txt dosyasına çevirmek

[mersilen]

Merhabalar

Cep telefonumun rehberini .csv veya .txt olarak kaydedebiliyorum.Bunlarıda excele çevirebiliyorum.Excelide .txt ye çevirebiliyorum ama istediğim düzende olmuyor.
Bir çalışmada bulduğum aşağıdaki kodları kendime nasıl adapte etmeliyim.
Teşekkürler.

Kod
http://www.excel.web.tr/f48/txt-dosyasy-olu-tur-butonu-t108724/sayfa3.html

Option Explicit
Sub aktar()
Dim klasor, dosyaadi, i, a, b, c, d, e
klasor = CreateObject("wscript.Shell").SpecialFolders.Item("Desktop")
dosyaadi = InputBox("Dosya adını yazın.", "UYARI!", Format(Now, "dd-mmm-yy h-mm-ss"))
If dosyaadi = "" Then
MsgBox "Dosya adı boş olamaz"
Exit Sub
End If
Open klasor & "\" & dosyaadi & ".txt" For Output As #1
For i = 1 To Worksheets("Txt Dosyası").Cells(Rows.Count, "a").End(3).Row
a = Worksheets("Txt Dosyası").Cells(i, 1).Value & " "
b = Worksheets("Txt Dosyası").Cells(i, 2).Value & " "
c = Worksheets("Txt Dosyası").Cells(i, 3).Value & " "
d = Worksheets("Txt Dosyası").Cells(i, 4).Value & " "
e = Worksheets("Txt Dosyası").Cells(i, 5).Value
Print #1, a & b & c & d & e
Next i
MsgBox dosyaadi & "  Dosyası masa üstüne kayıt edildi"
Close #1
End Sub

 

[Necdet]

Merhaba,

Başlıkları istemiyorsanız döngüyü 2. satırdan başlatınız.

Sub Aktar()
    
    Dim klasor, _
        dosyaadi, _
        i           As Long
        
    klasor = CreateObject("wscript.Shell").SpecialFolders.Item("Desktop")
    dosyaadi = InputBox("Dosya adını yazın.", "UYARI!", Format(Now, "dd-mmm-yy h-mm-ss"))
 
    If dosyaadi = "" Then
        MsgBox "Dosya adı boş olamaz"
        Exit Sub
    End If
 
    Open klasor & "\" & dosyaadi & ".txt" For Output As #1
 
    For i = 2 To Cells(Rows.Count, "a").End(3).Row
        Print #1, Range("A1") & vbTab & Cells(i, 1).Value
        Print #1, Range("B1") & vbTab & Cells(i, 2).Value
        Print #1, Range("C1") & vbTab & Cells(i, 3).Value
        Print #1, Range("D1") & vbTab & Cells(i, 4).Value
        Print #1, Range("E1") & vbTab & Cells(i, 5).Value
        Print #1, ""
    Next i
 
    MsgBox dosyaadi & "  Dosyası masa üstüne kayıt edildi"
 
    Close #1
 
End Sub

 

[mersilen]

Necdet bey cevap için teşekkürler.

İstediğim gibi olmadı (çalışmadı).
Rar dosyasının içindeki .txt dosyasına birebir benzemeli.

 

[Zeki Gürsoy]

- Birleşim "vbTab" ile olmalı...

- String in "unicode" a çevrilerek yazılması.

 

[Zeki Gürsoy]

Bu da istediğiniz sonucu verecek prosedur.

Sub Unicode_Test()
    Dim st As Object
    
    Set st = CreateObject("Scripting.FileSystemObject").CreateTextFile( _
        "C:\Unicode.txt", True, True)

    With st
        For i = 2 To [a65536].End(3).Row
            .WriteLine [a1] & vbTab & Cells(i, "a")
            .WriteLine [b1] & vbTab & Cells(i, "b")
            .WriteLine [c1] & vbTab & Cells(i, "c")
            .WriteLine [d1] & vbTab & Cells(i, "d")
            .WriteLine [e1] & vbTab & Cells(i, "e")
            .WriteBlankLines 1
        Next
            .Close
    End With
End Sub

 

[mersilen]

Bu da istediğiniz sonucu verecek prosedur.

Sub Unicode_Test()
    Dim st As Object
    
    Set st = CreateObject("Scripting.FileSystemObject").CreateTextFile( _
        "C:\Unicode.txt", True, True)

    With st
        For i = 2 To [a65536].End(3).Row
            .WriteLine [a1] & vbTab & Cells(i, "a")
            .WriteLine [b1] & vbTab & Cells(i, "b")
            .WriteLine [c1] & vbTab & Cells(i, "c")
            .WriteLine [d1] & vbTab & Cells(i, "d")
            .WriteLine [e1] & vbTab & Cells(i, "e")
            .WriteBlankLines 1
        Next
            .Close
    End With
End Sub

Zeki bey cevap için teşekkürler

--Exceldeki 5 adet kartvizit (telf no) kablolu bağlantı ile tlf 'na sorunsuz aktarıldı.
--Yalnız oluşturulan unicode.txt dosyası c: dizininde olduğu için bulunması sorun oluyor.
--Ayrıca bir kere oluşturulupta tekrar üstüne kayıt dediğimizde "variabl not defined" hatası veriyor.Bunların olmaması için tarihi içeren dosya adıyla desktop a kayıt etmesini sağlıyabilir misiniz?(yukarıdaki örneklerde olduğu gibi.)

 

[Zeki Gürsoy]

Sub Unicode_Test2()
    Dim st As Object, f As String, i As Long
    
    f = Environ("userprofile") & "\Desktop\Unicode.txt"
    
    If Dir(f) <> "" Then Kill f
    
    Set st = CreateObject("Scripting.FileSystemObject").CreateTextFile(f, True, True)

    With st
        For i = 2 To [a65536].End(3).Row
            .WriteLine [a1] & vbTab & Cells(i, "a")
            .WriteLine [b1] & vbTab & Cells(i, "b")
            .WriteLine [c1] & vbTab & Cells(i, "c")
            .WriteLine [d1] & vbTab & Cells(i, "d")
            .WriteLine [e1] & vbTab & Cells(i, "e")
            .WriteBlankLines 1
        Next
            .Close
    End With
End Sub

 

[mersilen]

Zeki bey sayenizde bu projede bayağı bir yol aldım.Çok teşekkür ederim.

Excelde 100 tane kartvizit (tlf no) oluşturup, unicode.txt dosyasına gönderip,
Nokia pc suit programı/dosya/al
yordamıyla telefon hafızasına 100 yeni isimi kaydettim.Herhangi bir sorun şimdilik yok.3-5 binlik bir deneme yapacağım.
Tek sorun pc suit in mükerrer kayıta izin vermesi olarak gözüküyor

 

[Necdet]

Necdet bey cevap için teşekkürler.

İstediğim gibi olmadı (çalışmadı).
Rar dosyasının içindeki .txt dosyasına birebir benzemeli.

Evet haklısınız o dosyayı incelemeyi unutmuşum.

İlgili mesajımda kodları değiştirdim, alternatif olsun.

 

[mersilen]

Evet haklısınız o dosyayı incelemeyi unutmuşum.

İlgili mesajımda kodları değiştirdim, alternatif olsun.

Necdet hocam sizin kodda düzgün çalışıyor.
Teşekkürler.