Excel VBA 指定文字の後ろに指定セルのデータを貼り付けるプログラムについて

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

この度自動化したい業務がございまして、皆様の
お知恵を拝借したく質問させていただきました。
下記の画像を参考にご説明させていただます。

A列には様々な種類の食品名の文字データが入力されており、
ここではりんご　すいか　みかんとします。
Cセルのハイフン(-)を除いたデータをA列より下記に貼り付けたいのですが、
ただ貼り付けるのではなく、りんごの後ろに貼り付けアンダーバーを
引きたい場合はどの様なプログラムの構成になるのでしょうか？

何卒よろしくお願いいたします。

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

• zongaiさん、回答ありがとうございます。
  誠に申し訳ございませんが、不明点がございましたので補足させていただきます。
  
  作成していただいたVBAの実行後の処理ですが、添付しました画像の動きとなりました。
  2行目のりんごのみ挿入が行われ、これより下記には挿入がされない様です。
  私が理想とします動きは6行目より下記の動きを理想とします。
  
  よろしくお願いいたします。

  
  No.5の回答に寄せられた補足コメントです。 補足日時：2021/04/17 22:54

• 申し訳ございません、重ね補足させていただきます。
  
  先程補足させていただいた内容に修正がございます。
  こちらに添付した画像での処理を理想の形としたいと思います。
  
  A4セルより下記の【りんご】をキーワードに
  C4セルより下記のデータを挿入させたいと思います。
  
  よろしくお願いいたします。

  
    補足日時：2021/04/18 01:24

• 先程No6の回答に気が付かず補足してしまいました。
  申し訳ございません。
  
  何卒宜しくお願いいたします。

    補足日時：2021/04/18 01:32

No.7 ベストアンサー 回答者： zongai 回答日時： 2021/04/18 05:42

補足拝見しました。

ちょっと丸投げし過ぎでは…
No.6がまるっきり無意味な回答になってしまいました。

No.5の回答で、概ね希望の動作になるはずですが、確認されてます？

処理開始行が4行目からなら…

>　　For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row 'A列1行目から最終行まで繰り返し

これが1行目から処理してるって書いてるんだから、
For i = 4 To ・・・
にすればいいんじゃないかなって想像つくと思うし、

挿入一覧のキーワードを挿入後に「-」に置き換える必要がないなら

> 　　　　　　Range("C" & i) = "-"　 '挿入が済んだので、挿入ワードを「-」に置き換える。

ここをまるっといらない（削除すればいい）と気づけそうだけど…

末尾に編集後のものを付けますが、
実際に No.5 の回答のもから、自分でいじって試してみることを勧めます。
いじることで挙動がどう変わるのか知ることでも、
VBAを覚えていくことにも繋がりますので。

---------------------
処理後の着色が必要なのかわからないけど、
No.5 を上記の編集したものに、着色処理の1行だけ追加したものです。

Sub Macro2()
　　Dim Key As String
　　Dim x As Integer
　　Dim i As Integer, j As Integer
　　Key = "りんご"　'挿入の目印となるキーワード
　　For i = 4 To Cells(Rows.Count, 1).End(xlUp).Row 'A列1行目から最終行まで繰り返し
　　　　If Range("C" & i) <> "-" And InStr(Range("A" & i), Key) > 0 Then
　　　　'挿入ワードが「-」ではなく、A列にKeyがあれば処理実行
　　　　　　Range("A" & i) = Replace(Range("A" & i), Key, Key & Range("C" & i))
　　　　　　'A列セルの[Key]　を　[Key + 挿入ワード]　に置き換える。
　　　　　　For j = 1 To Len(Range("A" & i)) - Len(Range("C" & i)) + 1
　　　　　　'A列セルの文字目から、[Key]のある位値を探していく
　　　　　　　　If Mid(Range("A" & i), j, Len(Key)) = Key Then
　　　　　　　　'[Key]がみつかったら…
　　　　　　　　　　Range("A" & i).Characters(Start:=j + Len(Key), Length:=Len(Range("C" & i))).Font.Underline = xlUnderlineStyleSingle
　　　　　　　　　　'その後に続く挿入ワードにアンダーラインを引く
　　　　　　　　End If
　　　　　　Next
　　　　　　Range("A" & i & ":C" & i).Interior.Color = 65535
　　　　　　'処理を行った箇所を着色
　　　　End If
　　Next
End Sub

この回答へのお礼

zongaiさんの仰る通りです。
失礼な態度、誠に申し訳ございません。

普段は自分で色々といじりこういう動きになるのだと関心に
重ねプログラムを編集し勉強するのですが、仕事に追われ
時間を作ることができませんでした。

知識が乏しい私の為にとても分かりやすく丁寧に
コメントを付けていただき大変感謝しております。

こちらのプログラムで理想の動きが実現でき、何時間も
かかっていた作業が一瞬で終わり感激しております。
心より感謝申し上げます。
ありがとうございました。

早速色々といじりVBAの勉強と共に、他の
業務の効率化向上に使わせていただきます。

今後ともこちらに質問させていただくと思いますが、
その際はどうぞよろしくお願いいたします。
この度は本当にありがとうございました。

お礼日時：2021/04/18 07:22

No.8 回答者： めぐみん_ 回答日時： 2021/04/18 06:04

丸っきり放置されて多分理想とは異なる結果なのでしょうね。

ま、知恵袋で慣れてはいますけど。
それにこの方法は１５年も前に他の回答者が類似した質問に対して回答していたコードの改良ですから、古臭くてダメだったのかと反省。

Sub megu_2()
Dim myReg As Object
Dim match, r As Range
Const keyword = "りんご" 'キーワード

Set myReg = CreateObject("VBScript.RegExp")
myReg.Global = True

For Each r In Range("A4", Cells(Rows.Count, "A").End(xlUp))

If r.Offset(, 2).Value <> "-" And InStr(r.Value, keyword) > 0 Then

With r
.Value = Replace(.Value, keyword, keyword & .Offset(, 2).Value)

myReg.Pattern = keyword & .Offset(, 2).Value

If myReg.Test(.Value) Then

For Each match In myReg.Execute(.Value)

.Characters(Start:=match.FirstIndex + Len(keyword) + 1, Length:=match.Length - Len(keyword)) _
.Font.Underline = xlUnderlineStyleSingle

Next

End If

End With

End If

Next

Set myReg = Nothing

End Sub

この回答へのお礼

めぐみんさん、いつもお世話になっております。
回答ありがとうございます。
無視する形となってしまい大変申し訳ございません。

めぐみんさんが改めて作成していただいたこちらの
VBAでも私が理想とする動きが実現できました。
早速色々といじらせていただき、少しずつでは
ありますが知識をつけていきたいと思います。

ありがとうございました。

お礼日時：2021/04/18 07:37

No.6 回答者： zongai 回答日時： 2021/04/17 23:05

挿入する言葉は

C列の各行にあるのではなく、
C1セルに限定されるということで良いでしょうか？

これでいかがでしょう？

Sub Macro2()
　　Dim Key As String
　　Dim x As Integer
　　Dim i As Integer, j As Integer

　　Key = "りんご"　'挿入の目印となるキーワード

　　For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row 'A列1行目から最終行まで繰り返し

　　　　If Range("C1") <> "-" And InStr(Range("A" & i), Key) > 0 Then
　　　　'挿入ワードが「-」ではなく、A列にKeyがあれば処理実行

　　　　　　Range("A" & i) = Replace(Range("A" & i), Key, Key & Range("C1"))
　　　　　　'A列セルの[Key]　を　[Key + 挿入ワード]　に置き換える。

　　　　　　For j = 1 To Len(Range("A" & i)) - Len(Range("C1")) + 1
　　　　　　'A列セルの文字目から、[Key]のある位値を探していく
　　　　　　　　If Mid(Range("A" & i), j, Len(Key)) = Key Then
　　　　　　　　'[Key]がみつかったら…
　　　　　　　　　　Range("A" & i).Characters(Start:=j + Len(Key), Length:=Len(Range("C1"))).Font.Underline = xlUnderlineStyleSingle
　　　　　　　　　　'その後に続く挿入ワードにアンダーラインを引く
　　　　　　　　End If
　　　　　　Next

　　　　End If
　　Next

End Sub

No.5 回答者： zongai 回答日時： 2021/04/17 11:14

コメント拝見しました。

> A列全てのりんごのキーワードに挿入することは可能でしょうか？

A列の全ての行に対して、ということ？
A列のセルにキーワードが複数存在しているケースのこと？

わからなかったので、両方取り込んでみました。

Sub Macro2()
　　Dim Key As String
　　Dim x As Integer
　　Dim i As Integer, j As Integer

　　Key = "りんご"　'挿入の目印となるキーワード

　　For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row 'A列1行目から最終行まで繰り返し

　　　　If Range("C" & i) <> "-" And InStr(Range("A" & i), Key) > 0 Then
　　　　'挿入ワードが「-」ではなく、A列にKeyがあれば処理実行

　　　　　　Range("A" & i) = Replace(Range("A" & i), Key, Key & Range("C" & i))
　　　　　　'A列セルの[Key]　を　[Key + 挿入ワード]　に置き換える。

　　　　　　For j = 1 To Len(Range("A" & i)) - Len(Range("C" & i)) + 1
　　　　　　'A列セルの文字目から、[Key]のある位値を探していく
　　　　　　　　If Mid(Range("A" & i), j, Len(Key)) = Key Then
　　　　　　　　'[Key]がみつかったら…
　　　　　　　　　　Range("A" & i).Characters(Start:=j + Len(Key), Length:=Len(Range("C" & i))).Font.Underline = xlUnderlineStyleSingle
　　　　　　　　　　'その後に続く挿入ワードにアンダーラインを引く
　　　　　　　　End If
　　　　　　Next

　　　　　　Range("C" & i) = "-"　 '挿入が済んだので、挿入ワードを「-」に置き換える。

　　　　End If
　　Next

End Sub

No.4 回答者： めぐみん_ 回答日時： 2021/04/17 10:57

Sub megu()

Dim myReg As Object
Dim match, r As Range
Const keyword = "りんご" 'キーワード

Set myReg = CreateObject("VBScript.RegExp")
myReg.Global = True

For Each r In Range("A1", Cells(Rows.Count, "A").End(xlUp))

If r.Offset(, 2).Value <> "-" And InStr(r.Value, keyword) > 0 Then

With r
.Value = Replace(.Value, keyword, keyword & .Offset(, 2).Value)

myReg.Pattern = keyword & .Offset(, 2).Value

If myReg.Test(.Value) Then

For Each match In myReg.Execute(.Value)

.Characters(Start:=match.FirstIndex + Len(keyword) + 1, Length:=match.Length - Len(keyword)) _
.Font.Underline = xlUnderlineStyleSingle

.Offset(, 2).Value = "-"

Next

End If

End With

End If

Next

Set myReg = Nothing

End Sub

違ってたらスル～して下さい。

No.3 回答者： めぐみん_ 回答日時： 2021/04/17 10:10

No.2です。

ついでではありますが、
『ばなな　すいか　りんご　みかん　りんご』
のような事についても気になりました。

No.2 回答者： めぐみん_ 回答日時： 2021/04/17 09:24

気になっただけです。

（初級者ですので）

Ｃ列の追加する文字がＡ列に事前に存在（”りんご”の後ろではない場所）している可能性はどうなのかなって思いました。

質問文で言えば、
『ばなな　すいか　りんご　みかん』
が
『ばなな　すいか　りんごばなな　みかん』
となる可能性の有無です。

No.1 回答者： zongai 回答日時： 2021/04/17 02:33

質問にかかれている内容は反映できる程度のもの。

Sub Macro1()
　　Dim Key As String
　　Dim x As Integer
　　
　　Key = "りんご"　'挿入の目印となるキーワード
　　
　　If Range("C1") = "-" Then Exit Sub　'挿入ワードが「-」なら終了
　　If InStr(Range("A1"), Key) = 0 Then Exit Sub　'A1セルにKeyが無ければ終了
　　
　　x = InStr(Range("A1"), Key) + Len(Key)　
　　'ワードが挿入される文字位置
　　'Keyの始まる文字位置 ＋ Keyの文字数

　　Range("A1") = Left(Range("A1"), InStr(Range("A1"), Key) + Len(Key) - 1) & _
　　　　Range("C1") & Mid(Range("A1"), x, Len(Range("A1")))
　　　　'Keyまでの文字 & 挿入ワード & Key以降の文字
　　　　'　とつなげて、A1セルへ書き込み
　
　　Range("A1").Characters(Start:=x, Length:=Len(Range("C1"))).Font.Underline = xlUnderlineStyleSingle
　　'A1セルで、ワード挿入位置から、ワードの文字数分だけ下線を引く
　　
　　Range("C1") = "-"　 '挿入が済んだので、挿入ワードを「-」に置き換える。
End Sub

この回答へのお礼

zongaiさん、回答いただきありがとうございます。
重ねこちらのVBAのプログラムありがとうございます。

実行させていただき早速で申し訳ないのですが、
A列全てのりんごのキーワードに挿入することは可能でしょうか？

よろしくお願いいたします。

お礼日時：2021/04/17 07:41