Excelのマクロで、文字列を同時に複数置換したいです。

Question

前提・実現したいこと

Excelのマクロで、以下のように文字列を同時に複数置換したいと思っております。
「0才→1才、1才→2才、2才→3才、3才→4才、4才→5才、5才→6才、6才→1年生、1年生→2年生、2年生→3年生、3年生→4年生、4年生→5年生、5年生→6年生、6年生→中学1年生」

発生している問題・エラーメッセージ

エラーメッセージなし

該当のソースコード

Sub MultiReplacement()
  Dim MyWords As Variant
  Dim MyRepWords As Variant
  Dim Ans As Integer
  Dim Rng As Range
  MyWords = Array("0才", "1才", "2才", "3才") 'ここに検索語を入れてください。
  MyRepWords = Array("1才", "2才", "3才", "4才")  'ここに置換語を入れてください。
  '検索語と置換語を調べる
  If UBound(MyWords) <> UBound(MyRepWords) Then
    MsgBox "検索語数( " & UBound(MyWords) & _
    " )と置換語数( " & UBound(MyRepWords) & " )数が違います。", 64
    Exit Sub
  End If
 
  Set Rng = Selection 'マウスで範囲を選択してください。
  If Rng.Count = 1 Then
    Ans = MsgBox("セル１つしか選択されていませんが、よろしいですか？", vbYesNo)
    If Ans = vbNo Then
      Exit Sub
    End If
  End If
  '実行
  For i = LBound(MyWords) To UBound(MyWords)
    Cells.Replace What:=MyWords(i), Replacement:=MyRepWords(i), _
    LookAt:=xlPart, _
    MatchCase:=True
  Next i
End Sub

試したこと

下のように、検索語：0才→置換後：1才、検索語：1才→置換後：2才と順番にやってしまうと、ループするため、全て4才になってしまいます。

▼動画リンク
https://gyazo.com/a84ef504b6d35dcb99055c2490a5dba6

検索語：Array("0才", "1才", "2才", "3才")
置換後：Array("1才", "2才", "3才", "4才") 

そこで、下の記事を参考に、一度記号に変換することで「0才→1才、1才→2才」までは置換することができました。

▼参考記事
https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1276108857

▼動画リンク
https://gyazo.com/7edb47b71c46ace1126a271da3142ca8

検索語：Array("0才", "1才", "@")
置換後：Array("@", "2才", "1才") 

しかし、その後、数を増やすとまたループしてしまって上手くいきません。

▼動画リンク
https://gyazo.com/4a1455d18f97721448003540e35ac921

検索語：Array("0才", "1才", "@", "3才", "2才", "@")
置換後：Array("@", "2才", "1才", "@", "3才", "4才") 

補足情報（FW/ツールのバージョンなど）

当方、マクロの使用は初めてで、下の記事を参考に設置させていただきました。

▼参考記事：エクセルの複数同時置換｜教えて！goo
https://oshiete.goo.ne.jp/qa/1350775.html

Excelのバージョンは2011です。

初心者で拙い部分も多いかと思いますが、コメントいただけると嬉しいです。
よろしくお願いいたします。

Answer 1

逆から行いましょう。
中学1年生→中学2年生
6年生→中学1年生
そうすればかぶらないです。

検索語：Array("3才", "2才", "1才", "0才")
置換後：Array("4才", "3才", "2才", "1才") 

Comments

[tedaeri.com]

radames1000様
早速ご回答いただきまして有難うございます！
逆から行うという発想は全く頭になく、感動しております。

アドバイスいただいた通りにやってみたところ、
「0才→1才、1才→2才、（中略）、5年生→6年生」までは成功しましたが、「6年生→中学1年生」にしたいところ、「6年生→中学2年生」となってしまいます。

また、最後は何故か置換後に指定していない「高校2年生」になってしまいました。
大変お手数ですが、もう少しご教授いただけませんでしょうか。

▼置換前と置換後の画像リンク
https://gyazo.com/4713d70e9f7291120be11ddde414220c

▼動画リンク
https://gyazo.com/c45d7687bfa0fbc7365d243c7de69aaf

▼該当部分のコード
---------------------
Sub MultiReplacement()
Dim MyWords As Variant
Dim MyRepWords As Variant
Dim Ans As Integer
Dim Rng As Range
MyWords = Array("中学3年生", "中学2年生", "中学1年生", "6年生", "5年生", "4年生", "3年生", "2年生", "1年生", "6才", "5才", "4才", "3才", "2才", "1才", "0才") 'ここに検索語を入れてください。
MyRepWords = Array("高校1年生", "中学3年生", "中学2年生", "中学1年生", "6年生", "5年生", "4年生", "3年生", "2年生", "1年生", "6才", "5才", "4才", "3才", "2才", "1才") 'ここに置換語を入れてください。
'検索語と置換語を調べる
If UBound(MyWords) <> UBound(MyRepWords) Then
MsgBox "検索語数( " & UBound(MyWords) & _
" )と置換語数( " & UBound(MyRepWords) & " )数が違います。", 64
Exit Sub
End If

Set Rng = Selection 'マウスで範囲を選択してください。
If Rng.Count = 1 Then
Ans = MsgBox("セル１つしか選択されていませんが、よろしいですか？", vbYesNo)
If Ans = vbNo Then
Exit Sub
End If
End If
'実行
For i = LBound(MyWords) To UBound(MyWords)
Cells.Replace What:=MyWords(i), Replacement:=MyRepWords(i), _
LookAt:=xlPart, _
MatchCase:=True
Next i
End Sub
---------------------

[tedaeri.com]

radames1000様
最初にご回答くださり有難うございました。
おかげ様で無事に解決いたしました。
ベストアンサー迷いましたが、実際に解決した方を選ばせていただきました。
また機会がありましたらよろしくお願いいたします。

[radames1000]

考慮が漏れていましたね。お気になさらず。

Answer 2

コード書いているうちに解決済みになってしまいしまたが、せっかくなので置いておきます。
ご参考になれば、幸いです。

Function AddAge(Age As String) As String
    Dim Ages As Variant
    Ages = Split("0才 1才 2才 3才 4才 5才 6才 1年生 2年生 3年生 4年生 5年生 6年生 " & _
                 "中学1年生 中学2年生 中学3年生")
    AddAge = Age
    On Error Resume Next
    AddAge = Ages(WorksheetFunction.Match(Age, Ages, 0))
End Function

Sub MultiReplacement()
    Dim Rng As Range, Ans As Long
    Set Rng = Selection    'マウスで範囲を選択してください。
    If Rng.Count = 1 Then
        Ans = MsgBox("セル１つしか選択されていませんが、よろしいですか？", vbYesNo)
        If Ans = vbNo Then
            Exit Sub
        End If
    End If
    
    Dim c As Range
    For Each c In Rng
        c.Value = AddAge(c.Value)
    Next
End Sub

Comments

[tedaeri.com]

hatena19様
コメントありがとうございます。
全く別の書き方でイチからコードを書いてくれるなんて...本当にありがとうございます！
こんな書き方もあるのかととても参考になりました。
また機会がありましたらよろしくお願いいたします。

Answer 3

初期案で全て同じ値になってしまうのは、小さい方から置換していることが原因だと思うので、
5才→6才、4才→5才という風に、大きい方から順に置換していくことで回避できると思いますが、如何でしょうか。

Comments

[tedaeri.com]

Usirow様
早速のご回答ありがとうございます！

アドバイスいただいた通りに逆からやってみたところ、
「0才→1才、1才→2才、（中略）、5年生→6年生」までは成功しましたが、「6年生→中学1年生」にしたいところ、「6年生→中学2年生」となってしまいます。

また、最後は何故か置換後に指定していない「高校2年生」になってしまいました。
大変お手数ですが、もう少しご教授いただけませんでしょうか。

▼置換前と置換後の画像リンク
https://gyazo.com/4713d70e9f7291120be11ddde414220c

▼動画リンク
https://gyazo.com/c45d7687bfa0fbc7365d243c7de69aaf

▼該当部分のコード
---------------------
Sub MultiReplacement()
Dim MyWords As Variant
Dim MyRepWords As Variant
Dim Ans As Integer
Dim Rng As Range
MyWords = Array("中学3年生", "中学2年生", "中学1年生", "6年生", "5年生", "4年生", "3年生", "2年生", "1年生", "6才", "5才", "4才", "3才", "2才", "1才", "0才") 'ここに検索語を入れてください。
MyRepWords = Array("高校1年生", "中学3年生", "中学2年生", "中学1年生", "6年生", "5年生", "4年生", "3年生", "2年生", "1年生", "6才", "5才", "4才", "3才", "2才", "1才") 'ここに置換語を入れてください。
'検索語と置換語を調べる
If UBound(MyWords) <> UBound(MyRepWords) Then
MsgBox "検索語数( " & UBound(MyWords) & _
" )と置換語数( " & UBound(MyRepWords) & " )数が違います。", 64
Exit Sub
End If

Set Rng = Selection 'マウスで範囲を選択してください。
If Rng.Count = 1 Then
Ans = MsgBox("セル１つしか選択されていませんが、よろしいですか？", vbYesNo)
If Ans = vbNo Then
Exit Sub
End If
End If
'実行
For i = LBound(MyWords) To UBound(MyWords)
Cells.Replace What:=MyWords(i), Replacement:=MyRepWords(i), _
LookAt:=xlPart, _
MatchCase:=True
Next i
End Sub
---------------------

[Usirow]

中学○年生の中の、○年生に反応しているせいですね。
可能であれば、小学○年生という風に変えてしまうという方法が一つ。
もしくは全てを一度年齢などに変換し、更に年齢を元に新しい値に書き直す、という処理がいいかと思います。

中学2年生→14→中学3年生
中学1年生→13→中学2年生
…
2年生→8→3年生
といった具合です。

[tedaeri.com]

Usirow様
ご返信ありがとうございます。

なるほど！「1年生」と「中学『1年生』」が被っているから反応してしまうということですね！
仰る通りに「小学1年生」にしたら出来ました！

一人で何日もかかっていたことがこんなに早く解決できて感動しております。
本当にありがとうございました。

解決済みのコードを以下に載せておきます。

▼動画リンク
https://gyazo.com/36a876610a64c28096d8319471f36859

▼最終的なコード
---------
Sub MultiReplacement()
Dim MyWords As Variant
Dim MyRepWords As Variant
Dim Ans As Integer
Dim Rng As Range
MyWords = Array("中学3年生", "中学2年生", "中学1年生", "小学6年生", "小学5年生", "小学4年生", "小学3年生", "小学2年生", "小学1年生", "6才", "5才", "4才", "3才", "2才", "1才", "0才") 'ここに検索語を入れてください。
MyRepWords = Array("高校1年生", "中学3年生", "中学2年生", "中学1年生", "小学6年生", "小学5年生", "小学4年生", "小学3年生", "小学2年生", "小学1年生", "6才", "5才", "4才", "3才", "2才", "1才") 'ここに置換語を入れてください。
'検索語と置換語を調べる
If UBound(MyWords) <> UBound(MyRepWords) Then
MsgBox "検索語数( " & UBound(MyWords) & _
" )と置換語数( " & UBound(MyRepWords) & " )数が違います。", 64
Exit Sub
End If

Set Rng = Selection 'マウスで範囲を選択してください。
If Rng.Count = 1 Then
Ans = MsgBox("セル１つしか選択されていませんが、よろしいですか？", vbYesNo)
If Ans = vbNo Then
Exit Sub
End If
End If
'実行
For i = LBound(MyWords) To UBound(MyWords)
Cells.Replace What:=MyWords(i), Replacement:=MyRepWords(i), _
LookAt:=xlPart, _
MatchCase:=True
Next i
End Sub
---------