Txt dosyası olarak kaydetmede satır boşluğu

[cengiz123]

Merhabalar

Makro ile getsaveas ile txt formatında dosya kaydediyorum.
Fakat normalde örneğin a ie e sütunları arasında, 100. Satırda biten verileri kaydettiğimde text dosyasında en alta boş bir satır oluşturuyor . Yani 101. Satır oluşturuyor ve bu satır boş. En alta Bu boş satırı oluşturmadan kaydetmenin bir yolu var mıdır? Yada txt de en altta bulunan bu boş satırı silmenin yolu.
Şimdiden teşekkür ederim

 

[TanerSaydam]

Makro kodunu koysanız daha kolay olurdu ama anladığım kadarıyla şöyle izah edeyim.

Son satır kodunuzu şu varsayarsak

Son = Range("A" Rows.Count).End(xlUp).Row

Son satıra kadar kaydet yazdığınız yere şöyle yazmalısınız

son - 1

 

[cengiz123]

dosyaadi = Application.GetSaveAsFilename
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:=dosyaadi & "txt", FileFormat:=xlText, CreateBackup:=False

kodlar yukarıda ki gibidir. txt olarak kaydedince sonda 1 satır boş bırakmaktadır.

 

[Necdet]

Merhaba,

Excel dosyasında son kaydın boş olduğu kesin mi?

 

[cengiz123]

100.satıra kadar dolu fakat kaydedilen txt dosyasında ektradan 1 boş satır gözüküyor.

 

[halit3]

Kayıt yapılan txt dosyasını aç sayfanın sonuna gel klavyede aşağı ok tuşuna bas son satırdan sonra imleç orada duracaktır eğer imlecin durduğu yer ile dolu olan son veri arasında boşluk varsa sizin söylediğiniz gibi boşluk var demektir eğer boşluk yoksa txt dosyası olarak kayıt yaptığınız dosyalarda aşağı ok tuşu ile sona gidildiğinde imleç son boşluk hücresinde durur

 

[cengiz123]

Son satırın altına imleç gidiyor.
O son satırı nasıl yok edebiliriz.

 

[cengiz123]

Text dosyasında en sltta bulunan, o son boşluk hücresini nasıl silebiliriz

 

[cengiz123]

Bu konuda yardımcı olabilecek var mı

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub TXT_AKTAR()
    Dim Dosya As Variant, Dosya_Adi As String, Alan As Range, Veri As Variant, X As Integer, Y As Integer
    
    Application.ScreenUpdating = False
    
    Dosya_Adi = "C:\Users\Desktop\test.txt"
    
    Set Dosya = CreateObject("Scripting.FileSystemObject").CreateTextFile(Dosya_Adi, True)
    
    Set Alan = Range("A1:G100")
    
    For X = 1 To Alan.Rows.Count
        For Y = 1 To Alan.Columns.Count
            If Alan.Cells(X, Y).Value <> "" Then
                If Veri = "" Then
                    Veri = Alan.Cells(X, Y).Value
                Else
                    Veri = Veri & vbTab & Alan.Cells(X, Y).Value
                End If
            End If
        Next
        If Veri <> "" Then Dosya.WriteLine Veri
        Veri = Empty
    Next
    
    Dosya.Close
    
    Dosya = Shell("Notepad.exe " & Dosya_Adi, vbNormalFocus)
    AppActivate Dosya
    SendKeys "^{END}", True
    SendKeys "{BS}", True
    SendKeys "^s", True
    SendKeys "%{F4}", True

    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[cengiz123]

Merhaba Korhan Bey
Kodunuz,
Txt dosyasının tüm içini silmektedir.
Hata olabilir mi

 

[Haluk]

Merhaba;

Korhan Bey konuyla ilginene kadar, aşağıdaki kodu deneyebilirsiniz.

A ve E sütunları arasındaki verileri, dosyanın kaydedilmiş olduğu dizindeki "YAZDIRILACAK.txt" dosyasına yazar. Text dosyasında ilave boş satır olmaması için kodda gerekli önlem alınmıştır.

Sub Test()
    kayıt_yeri = ThisWorkbook.Path & "\YAZDIRILACAK.txt"
    If Dir(kayıt_yeri) <> "" Then Kill kayıt_yeri
    Set adoStream = CreateObject("ADODB.Stream")
    adoStream.Charset = "utf-8"
    adoStream.Type = 2
    adoStream.Open
    NoA = Range("A65536").End(3).Row
    For i = 1 To NoA
        With Worksheets("Sheet1")
            adoStream.WriteText .Cells(i, 1) & vbTab
            adoStream.WriteText .Cells(i, 2) & vbTab
            adoStream.WriteText .Cells(i, 3) & vbTab
            adoStream.WriteText .Cells(i, 4) & vbTab
            adoStream.WriteText .Cells(i, 5) & vbTab
            adoStream.WriteText .Cells(i, 6) & vbTab
            If i = NoA Then Exit For
            adoStream.WriteText vbCrLf
        End With
    Next
    adoStream.SaveToFile kayıt_yeri
End Sub

.

 

[cengiz123]

Haluk bey merhaba
teşekkür ederim. tam istediğim gibi. son satırı siliyor.
bu koda şunu da ekleyebilir miyiz peki,
yazdırılacak dosyası içindeki bütün x400 görüdüklerileri yere S500 yazsın
böyle bir replace komutu da eklenebilir mi?
(ama bunu txt içerisinde yapacak)

 

[Haluk]

Merhaba;

Bunu deneyebilirsiniz,

Sub Test2()
    kayıt_yeri = ThisWorkbook.Path & "\YAZDIRILACAK.txt"
    If Dir(kayıt_yeri) <> "" Then Kill kayıt_yeri
    Set adoStream = CreateObject("ADODB.Stream")
    adoStream.Charset = "utf-8"
    adoStream.Type = 2
    adoStream.Open
    NoA = Range("A65536").End(3).Row
    For i = 1 To NoA
        With Worksheets("[COLOR=Red][B]Sheet1[/B][/COLOR]")
            adoStream.WriteText Replace(.Cells(i, 1), "x400", "S500") & vbTab
            adoStream.WriteText Replace(.Cells(i, 2), "x400", "S500") & vbTab
            adoStream.WriteText Replace(.Cells(i, 3), "x400", "S500") & vbTab
            adoStream.WriteText Replace(.Cells(i, 4), "x400", "S500") & vbTab
            adoStream.WriteText Replace(.Cells(i, 5), "x400", "S500") & vbTab
            adoStream.WriteText Replace(.Cells(i, 6), "x400", "S500") & vbTab
            If i = NoA Then Exit For
            adoStream.WriteText vbCrLf
        End With
    Next
    adoStream.SaveToFile kayıt_yeri
End Sub

 

[cengiz123]

Merhaba Haluk hocam
Kod çok işime yaradı. Gerçekten harika bi kod yazmışsınız.
Eliniz e sağlık çok teşekkür ederim

 

[Haluk]

Kolay gelsin ...:8)

 

[Korhan Ayhan]

Merhaba,

Merhaba Korhan Bey
Kodunuz,
Txt dosyasının tüm içini silmektedir.
Hata olabilir mi

Haluk bey konuya çözüm getirmiş... Bende önerdiğim kodu deneyerek foruma eklemiştim.

Uyarınız üzerine tekrar denedim. Bende bahsettiğiniz durum oluşmadı.

Uygulamalı dosyalar ektedir.