Excel内の一部の文字列の書式ごと置換する方法について

いつもお世話になっています。

質問タイトルのとおりなのですが、以下ページを参照して置換を試したところ、
セル内に置換したい文字列が複数回出てくる場合にうまくいきません。

https://oshiete.goo.ne.jp/qa/2428455.html

具体的には、セル内の最初の文字列は正常に置換され、書式も指定のものに変更されるのですが、
同じセル内に二回目以降に出現する文字列は置換も書式変更もされません。

例)
「私は犬が好きです。犬は私の友達です。」
の文章の「犬」を「猫」に置換しようとした場合、
「私は猫が好きです。犬は私の友達です。」
と、二回目の犬が置換されません。

この場合は、どのようにVBAを修正したらよろしいでしょうか。

質問者からの補足コメント

• ご回答ありがとうございます。
  
  リンク先を確認させていただきましたが、記載されている例ではセルの値が置換したい文字列と完全一致しないといけないようです。
  
  質問内容を補足をさせていただきます。
  
  今回置換したい文字列は、シート内の50ヶ所以上のセルに存在します。
  セル内には、置換したい文字列以外の文字列も含まれます。
  セル内には、置換したい文字列が複数回出現する場合もあります。
  置換後の文字列を、文字色を赤、取り消し線を有りに書式を変更したいです。(セル内の全ての文字列を対象にしたくない)
  
  https://oshiete.goo.ne.jp/qa/2428455.html
  のNo.4、No.5の回答を組み合わせる形で実行しましたが、
  同一セルに二回以上置換したい文字列が出現する場合、
  一番最初に出現するの置換希望文字列しか置換されません。
  
  よろしくお願い致します。

  No.1の回答に寄せられた補足コメントです。 補足日時：2020/04/02 09:39

• ご回答ありがとうございます。
  
  リンク先を確認させていただきましたが、記載されている例ではセルの値が置換したい文字列と完全一致しないといけないようです。
  
  質問内容を補足をさせていただきます。
  
  今回置換したい文字列は、シート内の50ヶ所以上のセルに存在します。
  セル内には、置換したい文字列以外の文字列も含まれます。
  セル内には、置換したい文字列が複数回出現する場合もあります。
  置換後の文字列を、文字色を赤、取り消し線を有りに書式を変更したいです。(セル内の全ての文字列を対象にしたくない)
  
  https://oshiete.goo.ne.jp/qa/2428455.html
  のNo.4、No.5の回答を組み合わせる形で実行しましたが、
  同一セルに二回以上置換したい文字列が出現する場合、
  一番最初に出現するの置換希望文字列しか置換されません。
  
  よろしくお願い致します。

  No.2の回答に寄せられた補足コメントです。 補足日時：2020/04/02 09:40

• ご回答ありがとうございます。
  記載いただいた形で置換されることは確認できましたが、置換後の文字列のみ
  書式変更する場合にはどのようにしたらよろしいでしょうか。
  
  質問内容を補足をさせていただきます。
  
  今回置換したい文字列は、シート内の50ヶ所以上のセルに存在します。
  セル内には、置換したい文字列以外の文字列も含まれます。
  セル内には、置換したい文字列が複数回出現する場合もあります。
  置換後の文字列を、文字色を赤、取り消し線を有りに書式を変更したいです。(セル内の全ての文字列を対象にしたくない)
  
  https://oshiete.goo.ne.jp/qa/2428455.html
  のNo.4、No.5の回答を組み合わせる形で実行しましたが、
  同一セルに二回以上置換したい文字列が出現する場合、
  一番最初に出現するの置換希望文字列しか置換されません。
  
  よろしくお願い致します。

  No.3の回答に寄せられた補足コメントです。 補足日時：2020/04/02 09:41

No.6 ベストアンサー 回答者： Qchan1962 回答日時： 2020/04/02 15:19

＃５です　置き換えもやるのでしたね

Sub ReplaceFormatInCells()も変更して

Sub ReplaceFormatInCells()
Dim sWhat As String, mWhat As String
Dim mFadd As String
Dim c As Range
　　sWhat = Application.InputBox("検索する単語を入れてください。", Type:=2)
　　If sWhat = "False" Or sWhat = "" Then Exit Sub
　　mWhat = Application.InputBox("置き換え後の単語を入れてください。", Type:=2)
　　If mWhat = "False" Or mWhat = "" Then Exit Sub
　　Cells.Replace what:=sWhat, replacement:=mWhat, lookat:=xlPart
　　Set c = ActiveSheet.UsedRange.Find( _
　　　　　　what:=mWhat, _
　　　　　　LookIn:=xlValues, _
　　　　　　lookat:=xlPart, _
　　　　　　SearchDirection:=xlNext, _
　　　　　　MatchCase:=True, _
　　　　　　MatchByte:=True)
　　If Not c Is Nothing Then
　　　　mFadd = c.Address
　　　　ReplaceFont c, mWhat
　　　　Do
　　　　　　Set c = ActiveSheet.UsedRange.FindNext(c)
　　　　　　If c.Address = mFadd Then Exit Sub
　　　　　　ReplaceFont c, mWhat
　　　　Loop Until c Is Nothing
　　End If
End Sub

Private Const の設定は不要です。

この回答へのお礼

再度のご回答ありがとうござました。
おかげさまで目的の操作が実現できました！

今回お二方から再回答をいただき、どちらも目的の操作が実現できましたが、
こちらのご回答内容の方が他の操作にも転用できて使い勝手が良さそうでしたのでベストアンサーとさせていただきます。

お礼日時：2020/04/05 22:13

No.5 回答者： Qchan1962 回答日時： 2020/04/02 15:05

リンク先のコードをお借りして（質問者が検証を行っていると思いますので）

先のPrivate Sub ReplaceFont(rng As Range, strSearch As String)を書き換えてみました。
Sub ReplaceFormatInCells()部分は、其のままで良いかと思います。

Private Sub ReplaceFont(rng As Range, strSearch As String)
Dim i As Integer
Dim Ln As Integer
　　Ln = Len(strSearch)
　　i = InStr(1, rng.Value, strSearch)
　　Do While i > 0
　　　　With rng.Characters(i, Ln)
　　　　　　.Font.ColorIndex = 3
　　　　　　.Font.Strikethrough = True
　　　　End With
　　　　i = InStr(i + Ln, rng.Value, strSearch)
　　Loop
End Sub

この回答へのお礼

再度のご回答ありがとうござました。
おかげさまで目的の操作が実現できました！

お礼日時：2020/04/05 22:13

No.4 回答者： tom04 回答日時： 2020/04/02 14:50

No.3です。

＞置換後の文字列を、文字色を赤、取り消し線を有りに書式を変更したいです。(セル内の全ての文字列を対象にしたくない)

単にデータだけでなく、書式も変えたい！というコトだったのですね。
どうも失礼しました。

セル全体の書式は簡単に変更できると思いますが、
セル内のある文字だけの書式変更は舐めるように順に検索していくしかないのでは？

↓のコードにしてみてください。
（尚、置換範囲はA1～H20セルとしています。）

Sub Sample2()
　Dim k As Long
　Dim c As Range, myRng As Range
　Dim myStr1 As String, myStr2 As String

　　myStr1 = "犬" '//←検索文字列//
　　myStr2 = "猫" '//←置換後の文字列//

　　　Set myRng = Range("A1:H20") '//ココで範囲指定//

　　　'//▼まず一気に置換//
　　　myRng.Replace what:=myStr1, replacement:=myStr2, lookat:=xlPart

　　　'//▼各セルの操作//
　　　　For Each c In myRng
　　　　　For k = 1 To Len(c)
　　　　　　If Mid(c, k, Len(myStr2)) = myStr2 Then
　　　　　　　With c.Characters(Start:=k, Length:=Len(myStr2)).Font
　　　　　　　　.Strikethrough = True
　　　　　　　　.ColorIndex = 3
　　　　　　　End With
　　　　　　End If
　　　　　Next k
　　　　Next c
End Sub

こんなんではどうでしょうか？

※　簡単にできる方法があればごめんなさい。m(_ _)m

この回答へのお礼

再度のご回答ありがとうございました。
おかげさまで目的の操作が実現できました！

お礼日時：2020/04/05 22:12

No.3 回答者： tom04 回答日時： 2020/04/01 18:42

こんにちは！

一例です。
具体的な配置が判らないので、すべてのセルを対象としてみました。

Sub Sample1()
　ActiveSheet.Cells.Replace what:="犬", replacement:="猫", lookat:=xlPart
End Sub

こんな感じではどうでしょうか？m(_ _)m

No.2 回答者： Qchan1962 回答日時： 2020/04/01 18:05

表題、書式ごと、、、すみません。

こちらは、参考になりますか

https://excelwork.info/excel/cellreplacereplacef …

No.1 回答者： Qchan1962 回答日時： 2020/04/01 17:51

例に合わせて回答すると

= Replace("私は犬が好きです。犬は私の友達です。", "犬", "猫")

参考：　http://officetanaka.net/excel/vba/function/repla …