Txt Makro

[leonadies]

Üstadlar Merhaba A sütunundan M sutununa kadar (Maksimum da 5000 satır) olan hücre verilerini "C:\Text" klasörü içine Txt uzantılı olarak makro ile nasıl çıkartabilirim?

Birde makroyu çalıştırınca TXT yi bu yola kaydederken hangi isimle kaydedeceğini sorsun istiyorum. Mümkün mü?

Sitede var olan kodları denedim ama yapamadım

 

[hamitcan]

Böyle deneyin.

Sub txtOlustur()
    Yol = ActiveWorkbook.Path
    Open Yol & "\" & "xx.TXT" For Output As #1

    For i = 2 To [a65536].End(3).Row - 1
    Print #1, Cells(i, 1) & vbTab _
     & Cells(i, 2) & vbTab _
     & Cells(i, 3) & vbTab _
     & Cells(i, 4) & vbTab _
     & Cells(i, 5) & vbTab _
     & Cells(i, 6) & vbTab _
     & Cells(i, 7) & vbTab _
     & Cells(i, 8) & vbTab _
     & Cells(i, 9) & vbTab _
     & Cells(i, 11) & vbTab _
     & Cells(i, 12) & vbTab _
     & Cells(i, 13)

    Next
    Close #1
    MsgBox "Text Dosyası Oluşturuldu"
End Sub

 

[Haluk]

Eğer C:\Text klasörü varsa;

Sub Test()
    'Haluk - 18/07/2019
    'E-Posta: sa4truss@gmail.com
    '
    Dim myFile As Variant, adoStream As Object, NoA As Long, i As Long
    Const adSaveCreateOverWrite = 2
    
    myFile = Application.GetSaveAsFilename(InitialFileName:="C:\Text", fileFilter:="Text Files (*.txt), *.txt")
    If myFile = False Then Exit Sub
    
    Set adoStream = CreateObject("ADODB.Stream")
    adoStream.Charset = "utf-8"
    adoStream.Type = 2
    adoStream.Open
    
    NoA = Range("A" & Rows.Count).End(xlUp).Row
    For i = 1 To NoA
        For j = 1 To 13
            adoStream.WriteText Cells(i, j) & vbTab
        Next
        adoStream.WriteText vbCrLf
    Next
    
    adoStream.SaveToFile myFile, adSaveCreateOverWrite
    adoStream.Close
    
    Set adoStream = Nothing
End Sub

 

[leonadies]

Sayın Hamitcan

Yol sabit dosyalar hep C:\Text klasörüne kayıt olacak. Kayıt yaparken sadece TXT uzantılı dosya adını ne diye kayıt etmek isteğimi sorsun yeter. Sizin makro ile isim sormadan excel nerede ise oraya kayıt atıyor. Ama çalışmasında sorun yok

 

[leonadies]

Kod:
Sub Test()
'Haluk - 18/07/2019
'E-Posta: sa4truss@gmail.com
'
Dim myFile As Variant, adoStream As Object, NoA As Long, i As Long
Const adSaveCreateOverWrite = 2

myFile = Application.GetSaveAsFilename(InitialFileName:="C:\Text", fileFilter:="Text Files (*.txt), *.txt")
If myFile = False Then Exit Sub

Set adoStream = CreateObject("ADODB.Stream")
adoStream.Charset = "utf-8"
adoStream.Type = 2
adoStream.Open

NoA = Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To NoA
For j = 1 To 13
adoStream.WriteText Cells(i, j) & vbTab
Next
adoStream.WriteText vbCrLf
Next

adoStream.SaveToFile myFile, adSaveCreateOverWrite
adoStream.Close

Set adoStream = Nothing
End Sub

Oldu teşekkür ederim Ancak şöyle bir durum oluştu. Veri sekmesi diye bir sayfam var. Bilgileri buraya giriyorum. Aslında buradan bazı bilgileri data sekmesine atıyor. Ben data sekmesindekileri txt yapmak istiyorum. Eksik bilgi vermiş oldum kusura bakmayın

 

[hamitcan]

Gerçi Haluk Üstad farklı bir çözüm vermiş ama ben yine de sorunuzu yanıtlayayım.

Sub txtOlustur()
    Yol = "c:\Text"
    dosyaismi = InputBox("Dosya ismini girin", , ".txt")
    Open Yol & "\" & dosyaismi For Output As #1

    For i = 2 To [a65536].End(3).Row - 1
    Print #1, Cells(i, 1) & vbTab _
     & Cells(i, 2) & vbTab _
     & Cells(i, 3) & vbTab _
     & Cells(i, 4) & vbTab _
     & Cells(i, 5) & vbTab _
     & Cells(i, 6) & vbTab _
     & Cells(i, 7) & vbTab _
     & Cells(i, 8) & vbTab _
     & Cells(i, 9) & vbTab _
     & Cells(i, 11) & vbTab _
     & Cells(i, 12) & vbTab _
     & Cells(i, 13)

    Next
    Close #1
    MsgBox "Text Dosyası Oluşturuldu"
End Sub

 

[leonadies]

Teşekkür ederim hamitcan hocam. Bu kodda gayet uygun