こんばんは。
これは、その都度、ファイルは閉じてはいますが、メモリとか使っているような気がしますね。あまり、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
お礼
ありがとうございます。 エクセルのバージョンは2000です。 残念ながらVBAはわかりません。 せっかく書いてもらったのによく理解できなくてすみません。