別ファイルで用意されたデータを元に文字を一括置換するには？

エクセル内の全シート、全セルにある文字をマクロで一括置換したいと思います。
置換したい文字は複数あり、その内容は別ファイル「置換.xls」に次のように記述されています。

　　 A列　　　B列
1　　等　　　など
2　　有り　　あり
3　　無し　　なし
※A列をB列に置換します。
※置換の項目数は、実際には3つではなく、100近くあります。

どのようなマクロを書けばよいのかお教えいただけませんでしょうか？
具体的なコードでなくても、方向性だけを示していただいても助かります。
よろしくお願いいたします。

Excel2003を利用しています。

No.4 ベストアンサー 回答者： Wendy02 回答日時： 2005/11/04 15:03

こんにちは。

Wendy02です。

http://oshiete1.goo.ne.jp/kotaeru.php3?q=1622180
xlsReplace　という私のマクロがあります。

ここで、その後のやり取りを少し読んでみてください。
#4 のコードの中で、
　LookAt:=xlWhole,
xlPart に直したほうがよいというお話になっていますが、単語検索で、部分置換か全置換かの違いです。

この回答への補足

前回に引き続き、ご回答いただきありがとうございます。
マクロを拝見させていただきました。
私の希望するものとは微妙に違いますが、大変参考になります。
少し修正を加えまして、セルに記述された文字を元に文字置換ができるようにしました。
あとは、このマクロとは逆の動作、つまり、文字の置換をかけたいファイルから、マクロを走らせて、検索文字と置換文字が記述された別ファイルを元に文字の置換がかけられれば完璧です。


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
Dim Row As Long

'============================================================

'ここは下位フォルダでも可能です。
Const myDrive As String = "D:\"
'
'============================================================

Row = Range("A" & Rows.Count).End(xlUp).Row

ReDim sWords(1 To Row)
For i = 1 To Row
sWords(i) = Cells(i, 1).Value
Next i

ReDim rWords(1 To Row)
For i = 1 To Row
rWords(i) = Cells(i, 2).Value
Next i

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:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False
Next k
'Replace の仕様:xlWhole=全一致
On Error GoTo 0
Err.Clear
Next
.Close True
End With
End Sub

補足日時：2005/11/06 00:33

No.5 回答者： Wendy02 回答日時： 2005/11/07 23:31

こんばんは。

＞文字の置換をかけたいファイルから、マクロを走らせて、検索文字と置換文字が記述された別ファイルを元に文字の置換がかけられれば完璧です。

ここまで分れば、すぐにお分りになるのではありませんか？
少し付け加えました。MYWORDS_BK として、ブック名を登録しておき、それを使います。

'============================================================
　 'ここは下位フォルダでも可能です。
　 Const myDrive As String = "D:\"
　 Const MYWORDS_BK As String = "D:\myWord.xls"　'用語ブック
　 '
　 '============================================================
　 With Workbooks.Open(MYWORDS_BK)
　　Row = .Worksheets("Sheet1").Range("A65536").End(xlUp).Row
　　ReDim sWords(1 To Row)
　　ReDim rWords(1 To Row)
　　For i = 1 To Row
　　　 sWords(i) = Cells(i, 1).Value '検索語
　　　 rWords(i) = Cells(i, 2).Value '置換語
　　Next i
　　 .Close False '用語取得終了
　 End With
'-------------------------------- つなげてください。
　ReDim Words(1, UBound(sWords))

'=======================================


Range("A" & Rows.Count).End(xlUp).Row
　　　　　　　　↓[ここで型の自動変換が行われている]
できるだけ、こういう場合は、リテラルに書いたほうが良いようです。
　　　　　　　　　　　　　　　　↓
.Worksheets("Sheet1").Range("A65536").End(xlUp).Row

この回答へのお礼

お礼が遅くなり大変申し訳ありません。
アドバイスのおかげで自分の希望にそったものができあがりました。
本当にありがとうございました！

お礼日時：2005/11/20 04:38

No.3 回答者： pon_kotu 回答日時： 2005/11/04 12:02

http://search.vector.co.jp/search?query=%92u%8A% …

にある、上から二つのやつが使えると思います。

わたしも、このマクロ書いてみましたが、結構てこずると思いますので、上記のものを利用されてみてはいかがでしょうか。

この回答へのお礼

お教えいただいたものは、検索文字欄が5データ分しかないようです。また、対象ファイルはテキストファイルとのことです。
私が希望しているものとは少し違うようです。

お礼日時：2005/11/05 07:52

No.2 回答者： Dxak 回答日時： 2005/11/04 11:57

とりあえずのコード例

Dim I As Long
Dim Tmp_Fm As String
Dim Tmp_To As String

I = 1
Tmp_Fm = Workbooks("Book2").Worksheets("Sheet1").Cells(I, 1).Value
Tmp_To = Workbooks("Book2").Worksheets("Sheet1").Cells(I, 2).Value

While Tmp_Fm <> ""
ActiveSheet.Cells.Replace _
What:=Tmp_Fm, _
Replacement:=Tmp_To, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:=False, _
ReplaceFormat:=False
I = I + 1
Tmp_Fm = Workbooks("Book2").Worksheets("Sheet1").Cells(I, 1)
Tmp_To = Workbooks("Book2").Worksheets("Sheet1").Cells(I, 2)
Wend

で、記載意味わかるかな？

この回答へのお礼

少し修正しまして、希望に近いものができました。
ただ、下記の点が希望に添いません。
アドバイスいただければ幸いです。

・置換.xlsを開いておかないと動作しない。
　→ 置換.xlsを開かずに動作させたいです。
・Sheet1以外のテキストが変換されない。
　→ 全てのシートを変換対象としたいです。


Sub xlsReplace2()

Dim i As Long
Dim Tmp_Fm As String
Dim Tmp_To As String
Const FName = "置換.xls"

i = 1
Tmp_Fm = Workbooks(FName).Worksheets("Sheet1").Cells(i, 1).Value
Tmp_To = Workbooks(FName).Worksheets("Sheet1").Cells(i, 2).Value

While Tmp_Fm <> ""
ActiveSheet.Cells.Replace _
What:=Tmp_Fm, _
Replacement:=Tmp_To, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:=False, _
ReplaceFormat:=False
i = i + 1
Tmp_Fm = Workbooks(FName).Worksheets("Sheet1").Cells(i, 1)
Tmp_To = Workbooks(FName).Worksheets("Sheet1").Cells(i, 2)
Wend

End Sub

お礼日時：2005/11/06 00:05

No.1 回答者： moon00 回答日時： 2005/11/04 11:53

方向性だけでもということで、回答を。

マクロの記録で、置換の作業を記録し、そのコード変更から考えてはいかがでしょうか。
検索語、置換語は用意した別ファイルのセルの値を
変数に代入し、
For～Next構文で、検索語のある限り繰り返し。
検索語・置換語を変数に代入するときと、置換作業をするときで、
それぞれ作業するファイルを切り替える必要があるので、
画面の更新はストップして、全作業終了後画面を更新。

コードが必要ならばまた挑戦してみたいと思います。

この回答へのお礼

マクロの記録でコードの基本的な流れを知ることができるのですね。
試してみます。
ありがとうございました。

お礼日時：2005/11/05 23:30