エクセルで複数のファイルの特定の文字の置き換え

質問

エクセルで同じフォルダに入っている複数のファイルがあります。（数百個）その中の特定の文字を別の文字に置き換えることは可能でしょうか？

回答No.4

Wendy02 · ベストアンサー

こんばんは。

これは、その都度、ファイルは閉じてはいますが、メモリとか使っているような気がしますね。あまり、IE などを開いたままには、このVBAマクロはお勧めできません。
シェアウェアでは、どうしているのでしょうね。このレベルでは、お金を取れるような内容ではありません。直接、ファイルに書き込むようなことをしなければね。

それから、たぶん、Excel97 では、無理だと思います。いままで、同じようなものは、何度も作ってきて、使ってはいただいていますが、今回は、複数の文字列の置換ということが、初めてです。(そのようなリクエストはありませんでしたけれど）一対一交換のものは、成功したものが別にあります。

例:
交換条件　→交換済み
5757AAAA　→5902BBB
コンマ(,)で区切って指定します。
フォルダの中は、全ての場合と、そうでない場合を想定しています。ファイル・オープンダイアログは、マルチセレクト(複数選択）が可能な状態です。

最初に、量を少なくして、バックアップを取ってから行ってください。

なお、私が解明できない不明なエラーがある時は、現在のこの版は、あっさりと見送り、以前のものを公開します。

'<標準モジュール>
Sub xlsReplace()
　 Dim objF As Object, Ret As Variant, Fnames() As Variant, Fname As Variant
　 Dim sWords$(), rWords$(), Words As Variant, i As Long, j As Long, OrgPath As String
'============================================================
　 '検索語
　 Const sWord = "交換条件,5757AAAA"
　 '置換語（上記と対にする）
　 Const rWord = "置換済み,5902BBB"
　 'ここは下位フォルダでも可能です。
　 Const myDrive As String = "C:\"
　 '
'============================================================
　 sWords = Split(sWord, ",")
　 rWords = Split(rWord, ",")
　 ReDim Words(1, UBound(sWords))
　 For i = LBound(sWords) To UBound(sWords)
　　　Words(0, i) = sWords(i)
　　　Words(1, i) = rWords(i)
　 Next i
　 OrgPath = CurDir
　 Set objF = CreateObject("Shell.Application"). _
　 BrowseForFolder(0, "フォルダを選んでください。", 0, myDrive)
　 If Not objF Is Nothing Then
　　　Ret = MsgBox(objF.items.Item.Path & "のフォルダのファイルを全て実行しますか？", _
　　　vbYesNoCancel)
　　　If Ret = vbYes Then
　　　　 ChDir objF.items.Item.Path
　　　　 Fname = Dir(objF.items.Item.Path & "\" & "*.xls")
　　　　 Do
　　　　　　ReDim Preserve Fnames(j)
　　　　　　Fnames(j) = Fname
　　　　　　j = j + 1
　　　　　　Fname = Dir
　　　　 Loop Until Fname = ""
　　　　 Application.ScreenUpdating = False
　　　　 For Each Fname In Fnames
　　　　　　Call ReplaceValues(CStr(Fname), Words)
　　　　 Next Fname
　　　　 Application.ScreenUpdating = True
　　　ElseIf Ret = vbNo Then
　　　　 ChDir objF.items.Item.Path
　　　　 Fnames = Application.GetOpenFilename("xls ファイル(*.xls),*.xls,全てのファイル(*.*),*.*", , , , True)
　　　　 If VarType(Fnames) = vbBoolean Then Exit Sub
　　　　 Application.ScreenUpdating = False
　　　　 For Each Fname In Fnames
　　　　　　Call ReplaceValues(CStr(Fname), Words)
　　　　 Next Fname
　　　　 Application.ScreenUpdating = True
　　　End If
　 End If
　 Set objF = Nothing
　 MsgBox "終了"
End Sub
'置換のサブルーチン
Private Sub ReplaceValues(Fname As String, ParamArray Words())
Dim wb As Worksheet, k As Long, arWords
arWords = Words
With Workbooks.Open(Fname)
For Each wb In .Worksheets
　　On Error Resume Next
For k = LBound(arWords(0), 2) To UBound(arWords(0), 2)
　wb.Cells.Replace What:=arWords(0)(0, k), _
　　　　　　　　　 Replacement:=arWords(0)(1, k), _
　　　　　　　　　 LookAt:=xlWhole, _
　　　　　　　　　 SearchOrder:=xlByRows, _
　　　　　　　　　 MatchCase:=False
Next k
'Replace の仕様:xlWhole=全一致
　　On Error GoTo 0
　　Err.Clear
Next
　 .Save
　 .Close True
End With
End Sub

お礼

ありがとうございます。
エクセルのバージョンは２０００です。
残念ながらＶＢＡはわかりません。
せっかく書いてもらったのによく理解できなくてすみません。