VBAでExcelファイルからテキストファイルを作成時に最終行に空白行が出ない様にしたい

Question

Excelファイルをテキスト化するツールをVBAで作成したのですが、添付画像の様に最終行に不要な空白行が作成されてしまいます。
最終行の一つ上の行の末尾に改行コードが有りそれを削除出来れば改善できると思います。
下記コードの最後のプロシージャがその為のコードなのですが上手く機能しません。
下記コードでおかしな所は有りますでしょうか？
もしくは他にテキストファイルの最終コードのみ削除する方法は有りますでしょうか？
お分かりになる方いらっしゃいましたらご教授をお願い致します。

Public WbName As String, WbPath As String, Alltxt As String
Public SfilePath As String
Public Wb As Workbook

Sub All()

    Call WbSet
    Call WriteTxt
    Call Sjis_To_Utf8
    
End Sub
Sub WbSet()
'*********************************************************
'* 対象ワークブックを開く
'*********************************************************
    
    Dim Openfilename As String
    Dim i As Integer
    Dim fso As Object
    
    Set fso = CreateObject("Scripting.FileSystemobject")
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    

    Openfilename = Application.GetOpenFilename("Microsoft Excelブック,*.xls?", , _
        "対象InputFileを選択して下さい")
    i = 0
    If Openfilename <> "False" Then
        Workbooks.Open Openfilename
        i = 1
    ElseIf i = 0 Then
        MsgBox "キャンセルされました"
        End
    End If
    
    '        ネットワークフォルダで実行するか、ローカルフォルダで実行するかの分岐
    If Left(ThisWorkbook.Path, 2) = "\" Then
        '        ネットワークフォルダで実行時
        With CreateObject("Wscript.Shell")
            .CurrentDirectory = ActiveWorkbook.Path
        End With
    Else
        '        ローカルフォルダで実行時
        ChDir ActiveWorkbook.Path
    End If
    
    If fso.FolderExists(ActiveWorkbook.Path & "\" & "txt") = False Then
            fso.CreateFolder (ActiveWorkbook.Path & "\" & "txt")
    End If
        
    Set Wb = ActiveWorkbook
    
    WbPath = ActiveWorkbook.Path & "\" & "txt"
    WbName = ActiveWorkbook.Name
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub

Sub WriteTxt()

    Dim rUsed As Range
    Dim r As Range
    Dim S As String, result As String
    Dim fs As New filesystemobject
    Dim ts As TextStream
    Dim IRow As Long
    Dim re As Object
    
    SfilePath = WbPath & "\" & Left(WbName, Len(WbName) - 5) & ".txt"
    
    Set ts = fs.CreateTextFile(SfilePath, True, False)
    
    Set rUsed = ActiveSheet.UsedRange
    
    IRow = 0
    
    For Each r In rUsed
        If IRow <> r.Row Then
            If r.Row <> rUsed.Row Or r.Column <> rUsed.Column Then
                S = S & vbCrLf
            End If
                S = S & r.Text
        Else
                S = S & vbTab & r.Text
        End If
            
            IRow = r.Row
    Next
    
'    S = Replace(S, vbCrLf, "")
    
'    Set re = CreateObject("VBScript.RegExp")
'
'    re.Pattern = vbCrLf & "+$"
'    result = re.Replace(S, "")
'    Set re = Nothing
'    S = result
    
'  Call DeleteCRLF(S)
  Call ts.WriteLine(S)
  Wb.Close
    
End Sub

Sub Sjis_To_Utf8()
    
    Dim streamRead As New ADODB.Stream
    Dim streamWrite As New ADODB.Stream
    Dim sText As Variant
    
'    ファイル読込
    streamRead.Type = adTypeText
    streamRead.Charset = "Shift-JIS"
    streamRead.Open
    Call streamRead.LoadFromFile(SfilePath)
    
'    改行コードの変換
    sText = streamRead.ReadText
    sText = Replace(sText, vbCrLf, vbLf)
    
'    ファイル書き込み
    streamWrite.Type = adTypeText
    streamWrite.Charset = "UTF-8"
    streamWrite.Open
    
'    Shift-JISデータをUTF-8にコピー
    Call streamWrite.WriteText(sText)
    
'    バイナリモードで書き込み済みデータ開始位置をBOM分の3バイトをずらす
    streamWrite.Position = 0
    streamWrite.Type = adTypeBinary
    streamWrite.Position = 3
    
'    3バイトずらした状態のデータを取得
    sText = streamWrite.Read
    
'    ずらした開始位置を元に戻す
    streamWrite.Position = 0
    
'    BOMが除去されたデータを先頭から書き込みなおす
    Call streamWrite.Write(sText)
    
'    現時点の末尾を終端とし､直前に書き込まれていた3バイトをデータ対象外とする
    streamWrite.SetEOS
    
    Call streamWrite.SaveToFile(SfilePath, adSaveCreateOverWrite)
    
    streamRead.Close
    streamWrite.Close
    
    MsgBox SfilePath & " 出力いたしました"
    
End Sub
 
 Public Function DeleteCRLF(ByVal strNewFileLine As String)

    Dim re As Object
    Dim result As String
    
    Set re = CreateObject("VBScript.RegExp")
    
    re.Pattern = "\n+$"
'    re.Pattern = vbCrLf & "+$"
    result = re.Replace(strNewFileLine, "")
    Set re = Nothing
    DeleteCRLF = result
    
'    Call ts.WriteLine(DeleteCRLF)
    
End Function
コード

Comments

[mdj]

ちゃんと考えていないのでコメントに。 WriteTxt()で ts.WriteLine(S) を止めて S を戻り値にして Sjis_To_Utf8 に渡せば読み込みいらないような。あとはこれでも改行がでるなら S の末尾が改行改行なのかな？

[退会済みユーザー]

下記ご回答いただいた方のご指摘箇所修正で解決出来ました。
コメントありがとうございました。

Answer 1

WriteLine()だとメソッド名通り出力の最後に改行が出力されるので、Write()でいいのではないでしょうか。

  ' Call ts.WriteLine(S)
  Call ts.Write(S)

Comments

[退会済みユーザー]

ご指摘の通りで解決出来ました。
有難う御座いました。