[[20200804104357]]　『キーワードを含む文章を見つけたら、行頭にキーワ』（えだまめ）　ページの最後に飛ぶ

『キーワードを含む文章を見つけたら、行頭にキーワードを付け加えたい』（えだまめ）

お知恵をお貸しください。

シート1のA1に「りんご」A2に「バナナ」A3に「すいか」…というようなキーワードがあります
シート2のA1に「おいしいりんごの詰め合わせ」A2に「甘くておいしいスイカ」A3に「産地直送バナナ」…といった文章がありあます

シート2の文章にシート1のキーワードが入っていたら、下記のようにそのキーワードを先頭に付け加える処理をしたいです

「おいしいりんごの詰め合わせ」⇒「りんご　おいしいりんごの詰め合わせ」
「甘くておいしいスイカ」⇒「スイカ　あまくておいしいスイカ」
「産地直送バナナ」⇒「バナナ　産地直送バナナ」

変更した文章は元々のセルに上書きするかたちで実行したいです。

ご教授よろしくお願い致します。

＜使用 Excel：Office365、使用 OS：Windows10 ＞

Sub main()

    Dim c  As Range, r As Range
    For Each c In Sheets("Sheet1").Range("A:A").SpecialCells(2)
        Set r = Sheets("Sheet2").Range("A:A").Find(c.Value, , , xlPart)
        If Not r Is Nothing Then r.Value = c.Value & Space(1) & r.Value
    Next c
End Sub
（mm） 2020/08/04(火) 11:12

mm様、ご教示ありがとうございます。
私の説明不足で申し訳ありません。1点付け加えていただきたくお伺い致します。
シート2にキーワードを含む文章がひとつだけではなく、複数あった場合、すべてを書き換えるにはどのようにすればよろしいでしょう。

「おいしいりんごの詰め合わせ」⇒「りんご　おいしいりんごの詰め合わせ」
「Lサイズりんご2ケース」⇒「りんご　Lサイズりんご2ケース」

というようにキーワードを含む文章が複数あり、それぞれに付け加えたく存じます。

大変恐れ入りますがお知恵をお貸しください。よろしくお願い申し上げます。
（えだまめ） 2020/08/04(火) 12:33

Sub main()

    Dim c  As Range, r As Range, f As Range
    For Each c In Sheets("Sheet1").Range("A:A").SpecialCells(2)
        Set r = Sheets("Sheet2").Range("A:A").Find(c.Value, , , xlPart)
        If Not r Is Nothing Then
            Set f = r
            r.Value = c.Value & Space(1) & r.Value
            Do
                Set r = Sheets("Sheet2").Range("A:A").FindNext(r)
                If r.Address = f.Address Then
                    Exit Do
                Else
                     r.Value = c.Value & Space(1) & r.Value
                End If
            Loop
        End If
    Next c
End Sub
（mm） 2020/08/04(火) 13:00

ありがとうございます！

とても速く対応していただいて感謝申し上げます！
（えだまめ） 2020/08/04(火) 13:20

コメント返信：

[ 一覧(最新更新順) ]

[[20200804104357]] 『キーワードを含む文章を見つけたら、行頭にキーワ』（えだまめ） ページの最後に飛ぶ

[[20200804104357]]　『キーワードを含む文章を見つけたら、行頭にキーワ』（えだまめ）　ページの最後に飛ぶ