VBA初心者です。txtファイルの一括編集について

初歩的な質問で申し訳ございません。。
そもそもの考え方(作業手順)が間違っているのかもしれませんが
VBAにて以下を実現したいのですが、③がどうしてもうまくいきません。。
①数千行あるエクセルファイルを200行毎に分割してシートに分ける。
②分割したシートを全てtxtファイル(1ファイルづつ)に変換して同フォルダ内に保存する。
③保存したtxtファイル(複数)の末尾の改行を削除して上書き保存する。

※VS CODEの一括変換も試みたのですが、うまくいきませんでした。

③でファイル指定し、指定したファイルの中でtxtファイルのみ③を実行できる術はありますでしょうか。

※業務で使用する作業シート作成で、アップロード先のシステムが最終行の改行にエラーを返すもので、、

↓以下のような内容です。
・・・・・・・・・・・・・
111-11-1111-1111 0
222-22-2222-2222 0
333-33-3333-3333 0
・
・
・　←200行目
　　←この最後の改行を複数のtxtファイル(フォルダ指定)に一括削除を行いたい。
・・・・・・・・・・・・・

申し訳ございませんが、ご教示何卒よろしくお願いいたします。

質問者からの補足コメント

• 

  自分なりに色々調べて以下のようにしたのですが、うまくいきませんでした。
  ↓
  Sub 末尾改行一括削除()
  Dim myPath As String
  Dim myFile As String
  
  On Error Resume Next
  
  myPath = ThisWorkbook.Path
  
  myFile = Dir(myPath & "\" & "*.txt")
  Do Until myFile = ""
  
  Workbooks.Open myPath & "\" & myFile
  Sheets("Sheet1").Select

    補足日時：2021/05/12 09:48

• ↓続き
  Set re = CreateObject("VBScript.RegExp")
  
  re.Pattern = vbCrLf & "+$"
  result = re.Replace(strNewFileLine, "")
  
  Set re = Nothing
  DeleteCRLF = result
  
  ActiveWorkbook.Close savechanges:=True
  
  myFile = Dir()
  Loop
  End Sub
  
  動作はするのですが、元ファイルの状態から変化がございません。。
  誤りございましたらご指摘とご教示いただけますと幸いでございます。
  何卒よろしくお願いいたします。

    補足日時：2021/05/12 09:52

No.4 ベストアンサー 回答者： ぽち101 回答日時： 2021/05/12 10:40

連続ですみません・・・。

No.3で不要な行がありましたので下記の１行を削除して試してみてください。
＞Debug.Print myPath & "\" & myFile

この回答へのお礼

お忙しい中ご返信下さりありがとうございます。
頂戴しました内容を実行しましたところ、無事解決いたしました！
詳細の理解には至っておりませんので、この後勉強させていただきます。
この度は勉強の機会を与えてくださり、誠にありがとうございました！

お礼日時：2021/05/12 13:29

No.3 回答者： ぽち101 回答日時： 2021/05/12 10:38

質問者さんに補足していただいたコードを修正しましたので、

No.2は無視して下記で試してみてください。


Sub 末尾改行一括削除()

Dim myPath As String
Dim myFile As String

Dim myFSO As Object
Dim myRE As Object
Dim myTXT As String

On Error Resume Next

myPath = ThisWorkbook.Path
myFile = Dir(myPath & "\" & "*.txt")

Set myFSO = CreateObject("Scripting.FileSystemObject")
Set myRE = CreateObject("VBScript.RegExp")

Do Until myFile = ""
Debug.Print myPath & "\" & myFile

With myFSO.OpenTextFile(myPath & "\" & myFile)
myTXT = .ReadAll
.Close
End With

myRE.Pattern = vbCrLf + "$"
myTXT = myRE.Replace(myTXT, "")

With myFSO.OpenTextFile(myPath & "\" & myFile, 2)
.Write myTXT
.Close
End With

myFile = Dir()
Loop

Set myFSO = Nothing

End Sub

No.2 回答者： ぽち101 回答日時： 2021/05/12 10:24

返事遅れてすみません。

これで動作しますでしょうか？
（ファイル名パス部分やループ処理は追加変更してください）

Sub 末尾改行一括削除()

a = "D:\Sample.txt"

Dim myFSO As Object
Dim myTXT As String
Dim RE As Object

Set myFSO = CreateObject("Scripting.FileSystemObject")

With myFSO.OpenTextFile(a)
myTXT = .ReadAll
.Close
End With

Set RE = CreateObject("VBScript.RegExp")
RE.Pattern = vbCrLf + "$"
myTXT = RE.Replace(myTXT, "")

With myFSO.OpenTextFile(a, 2)
.Write myTXT
.Close
End With

Set myFSO = Nothing

End Sub

No.1 回答者： ぽち101 回答日時： 2021/05/10 20:58

・その改行の改行コードは分かりますか？

　例えば改行コードがCRLFなら、Chr(13)とChr(10)をReplaceするとどうでしょうか？
　※txtの文字コード（UTF-8、BOM有なども分かるといいかもしれないですね。）

・txtへ保存する処理のVBAコードを教えていただくことは可能ですか？

この回答へのお礼

早速のご返信ありがとうございました。
基礎情報が漏れておりお手間取らせてしまい申し訳ございません。

改行コード：CRLF
txt文字コード：UTF-8
となります。

②の処理は以下にて行っております。

MsgBox "フォルダを指定してtxtファイルに変換する"

'対象ブックをダイアログで指定する
Dim FName As String
FName = Application.GetOpenFilename _
(FileFilter:="Microsoft Excelブック,*.xls*")

If FName <> "False" Then
Workbooks.Open Filename:=FName
Else
Exit Sub 'ファイルが選択されていない場合は終了
End If

Dim ws As Worksheet
For Each ws In Worksheets '各シートに対して処理を繰り返す

ws.Activate
'元のブックと同じ階層に出力
ActiveWorkbook.SaveAs _
Filename:=ActiveWorkbook.Path & "\" & ws.Name & ".txt", _
FileFormat:=xlText

Next ws

ActiveWorkbook.Close SaveChanges:=False

MsgBox "ファイル作成が完了しました。"

End Sub

例えば改行コードがCRLFなら、Chr(13)とChr(10)をReplaceするとどうでしょうか？
⇒勉強になりました！確認しチャレンジ致します。

引き続きどうぞよろしくお願いいたします。

お礼日時：2021/05/11 09:43