EXCEL VBAコミュのカレントディレクトリ内のファイル一括置換

初めましてvba始めてまだ一カ月も経っていない初心者です
現在、複数ファイルに対して置換を行うプログラムを作っています。単一のファイルに対しての置換はできたのですが、複数ファイルに対しての置換ができません。

ソースは以下です
--------------------------------------
Sub setDate()
Dim baseFile As String
Dim newFile As String
Dim Stream As Object
Dim Stream2 As Object
Dim buf As String
Set Stream = CreateObject("ADODB.Stream")
Set Stream2 = CreateObject("ADODB.Stream")
Dim myfdr As String
Application.ScreenUpdating = False '画面更新を一時停止
myfdr = ThisWorkbook.Path 'フォルダー名取得
baseFile = Dir(myfdr & "\*.txt") 'フォルダ内のtxtファイルを検索
Do Until baseFile = Empty '全て検索 Do While baseFile <> ""
'Set newFile = Workbooks.Open(myfdr & "\" & baseFile) 'そのファイルを開きwb
とする。
n = n + 1 'カウントしnとする
'wb = Replace(wb, ">", "<a href=""#1"" title=本文へ></a>>")
Stream.Open
Stream.Type = 2 '文字列で保存
Stream.Charset = "utf-8" '文字列をutf-8で取得
Stream.LoadFromFile baseFile 'basefaile読み込み
buf = Stream.readText()
Stream.SaveToFile newFile, 2
buf = Replace(buf, "blue", "red")
Stream2.Open
Stream2.Type = 2
Stream2.Charset = "utf-8"
Stream2.WriteText (buf)
Stream2.SaveToFile newFile, 2
Stream.Close
Stream2.Close
'wb.Close (True) '開いたファイルを保存して閉じる
baseFile = Dir 'フォルダ内の次のtxtファイルを検索
Loop '繰り返す
Application.ScreenUpdating = True '画面更新一時停止を解除
If Dir(myfdr & "\*.txt") <> "" Then
MsgBox n & "件を処理しましました。"
MsgBox "変換終了"
Else
MsgBox "ファイルは存在しません。", vbInformation
End If
End Sub
---------------------------------

どなたか、わかる方がいらっしゃったらご教授ください
よろしくお願いいたします

コメント(7)

最初
全て
最新の40件

[1] mixiユーザー 01月20日 21:15

単一での置換は以下のソースです。

-----------------------------
Sub setDate()
Dim baseFile As String
Dim newFile As String

Dim Stream As Object
Dim Stream2 As Object
Dim buf As String
Set Stream = CreateObject("ADODB.Stream")
Set Stream2 = CreateObject("ADODB.Stream")
'basefaileオープン
Stream.Open
'文字列で保存
Stream.Type = 2
Stream.Charset = "utf-8"
Stream.LoadFromFile baseFile
buf = Stream.readText()
Stream.SaveToFile newFile, 2
buf = Replace(buf, "blue", "red")
Stream2.Open
Stream2.Type = 2
Stream2.Charset = "utf-8"
Stream2.WriteText (buf)
Stream2.SaveToFile newFile, 2
Stream.Close
Stream2.Close
MsgBox "変換終了"
End Sub

--------------------------
以上、よろしくお願いいたします

[2] mixiユーザー 01月20日 21:46

惜しいところまで行ってる形跡がありましたので、ちょっとだけ変えてみました。
置換語のファイル名は置換前のファイル名＋".rep"にしてあります。
～～～～～～～～～～～～～
Option Explicit

Sub setDate()
Dim baseFile As String
Dim newFile As String
Dim Stream As Object
Dim Stream2 As Object
Dim buf As String
Set Stream = CreateObject("ADODB.Stream")
Set Stream2 = CreateObject("ADODB.Stream")
Dim myfdr As String
Application.ScreenUpdating = False '画面更新を一時停止
myfdr = ThisWorkbook.Path 'フォルダー名取得
baseFile = Dir(myfdr & "\*.txt") 'フォルダ内のtxtファイルを検索
Dim n As Long
n = 0
Do Until baseFile = Empty '全て検索 Do While baseFile <> ""
newFile = baseFile & ".rep" ' Workbooks.Open(myfdr & "\" & baseFile) 'そのファイルを開きwbとする｡
n = n + 1 'カウントしnとする
'wb = Replace(wb, ">", "<a href=""#1"" title=本文へ></a>>")
Stream.Open
Stream.Type = 2 '文字列で保存
Stream.Charset = "utf-8" '文字列をutf-8で取得
Stream.LoadFromFile baseFile 'basefaile読み込み
buf = Stream.readText()
Stream.SaveToFile newFile, 2
buf = Replace(buf, "blue", "red")
Stream2.Open
Stream2.Type = 2
Stream2.Charset = "utf-8"
Stream2.WriteText (buf)
Stream2.SaveToFile newFile, 2
Stream.Close
Stream2.Close
'wb.Close (True) '開いたファイルを保存して閉じる
baseFile = Dir 'フォルダ内の次のtxtファイルを検索
Loop '繰り返す
Application.ScreenUpdating = True '画面更新一時停止を解除
If Dir(myfdr & "\*.txt") <> "" Then
MsgBox n & "件を処理しましました。"
MsgBox "変換終了"
Else
MsgBox "ファイルは存在しません。", vbInformation
End If
End Sub

[3] mixiユーザー 01月20日 22:17

＞トキハさん
お忙しいところご回答ありがとうございます。

変更して頂いたコードなんですが・・・

「ファイルが開けません」

というエラーが出て

Stream.LoadFromFile baseFile 'basefaile読み込み

のところがマーキング（？）されます。
これは、baseFileが空っていうことなんでしょうか・・・

申し訳ありませんが、よろしかったらご教授ください

[4] mixiユーザー 01月20日 22:27

baseFileは「エクセルファイルが保存してある」カレントディレクトリにある、拡張子が.txtのファイルをループでまわしていますよね？
ファイルが開けないということは、エクセルを保存していないため、カレントディレクトリが分からない場合が考えられます。
マーキングが出た行の前に
msgbox baseFile
と記述して、実際にbaseFileに何が入ってるか確認してもらえませんか？

[5] mixiユーザー 01月20日 22:34

＞baseFileは「エクセルファイルが保存してある」カレントディレクトリにあ＞＞る、拡張子が.txtのファイルをループでまわしていますよね？
はい、そうです。

>msgbox baseFile
>と記述して、実際にbaseFileに何が入ってるか確認してもらえませんか？
今、エクセルを保存してあるｶﾚﾝﾄﾃﾞｨﾚｸﾄﾘにaomori.txtというファイルを入れていて、その表示がちゃんと出てきました

トキハさんの環境では動きました？

よろしくお願いいたします

[6] mixiユーザー 01月20日 22:48

はい、私の環境でちゃんと動きましたよー！
あ、もしかしたら、パス関係がちゃんとできてないからかもしれませんので、
このようにしたらきちんと動くかもです。
basefileを読み込むときにちゃんとパスを追加しました。
～～～～～～～～～～～～～～～～～～～
Option Explicit

Sub setDate()
Dim baseFile As String
Dim newFile As String
Dim Stream As Object
Dim Stream2 As Object
Dim buf As String
Set Stream = CreateObject("ADODB.Stream")
Set Stream2 = CreateObject("ADODB.Stream")
Dim myfdr As String
Application.ScreenUpdating = False '画面更新を一時停止
myfdr = ThisWorkbook.Path 'フォルダー名取得
baseFile = Dir(myfdr & "\*.txt") 'フォルダ内のtxtファイルを検索
Dim n As Long
n = 0
Do Until baseFile = Empty '全て検索 Do While baseFile <> ""
newFile = baseFile & ".rep" ' Workbooks.Open(myfdr & "\" & baseFile) 'そのファイルを開きwbとする｡
n = n + 1 'カウントしnとする
'wb = Replace(wb, ">", "<a href=""#1"" title=本文へ></a>>")
Stream.Open
Stream.Type = 2 '文字列で保存
Stream.Charset = "utf-8" '文字列をutf-8で取得
Stream.LoadFromFile (myfdr & "\" & baseFile) 'basefaile読み込み
buf = Stream.readText()
Stream.SaveToFile newFile, 2
buf = Replace(buf, "blue", "red")
Stream2.Open
Stream2.Type = 2
Stream2.Charset = "utf-8"
Stream2.WriteText (buf)
Stream2.SaveToFile myfdr & "\" & newFile, 2
Stream.Close
Stream2.Close
'wb.Close (True) '開いたファイルを保存して閉じる
baseFile = Dir 'フォルダ内の次のtxtファイルを検索
Loop '繰り返す
Application.ScreenUpdating = True '画面更新一時停止を解除
If Dir(myfdr & "\*.txt") <> "" Then
MsgBox n & "件を処理しましました。"
MsgBox "変換終了"
Else
MsgBox "ファイルは存在しません。", vbInformation
End If
End Sub

[7] mixiユーザー 01月20日 23:11

トキハさん

ありがとうございました！
実行できました！

自分はまだまだ勉強が足りないので、これからまた頑張っていきます。
本当にありがとうございました！

ログインすると、みんなのコメントがもっと見れるよ