部分一致かつ文字数が短いときに隣の列に検索値を与えたい

Question

###前提・実現したいこと
下記内容を実現するにあたり、コードについて教えていただければ幸いです。

A B C
みかん
りんご りんごジュース りんご缶
りんごジュース
すいか すいか割り
りんご缶
すいか割り

A列がすでに入力済みで、B、C列はVBAを実行することで自動で値を入力したいと考えています。
A列を上から検索値として下方向に検索をかけて、部分一致かつ文字が検索値より長い場合に、同じ行の隣の列(B、C、D)に検索値を与えたいです。

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

今現在は下記内容までできていますが、①②③が分からず、皆様からご教授いただければと思います。
※そもそも実現可能なのでしょうか。

Dim c As Object
Dim searchWord As Variant
Dim Target As Range
Dim firstWord As String '最初の検索

Set Target = Range("A1")
'①検索値を列方向へ移動

searchWord = Target.Value

    Set c = Range("B4:B5000").Find(searchWord, LookAt:=xlPart) '②検索値よりも長い単語を条件
    If c Is Nothing Then
        MsgBox searchWord & "は見つかりませんでした。"
    End If
    
    firstWord = c.Address
    '③同じ行の隣の列に値を貼り付け

    Do ' c に対する処理
    ' 次を検索
        Set c = Cells.FindNext(c)
        If c Is Nothing Then
            Exit Do
        End If
        If c.Address = firstWord Then
            Exit Do
        End If
        '③同じ行の隣の列に値を貼り付け
    Loop

①：検索値を下方向へずらしていく。Offsetで可能？
②：検索条件として、検索値よりも長い単語を検索結果としたい場合、どこに条件をいれるのがいいのか。
③：検索結果としてヒットした単語の隣の行に検索値を与える。B列が埋まっている場合は、C列にというやり方がわかりません。。。

VBA自体これまでやってこなかったこともあり、質問も分かりずらいかと思いますが、ご教授願います。

Comments

[hatena19]

出力例で、「りんご缶 りんごジュース」というのがありますが、部分一致という場合、通常は「検索値」が「検索対象」の一部（含まれる）という意味になりますが、りんご缶 はりんごジュースの一部ではないですよね。これも結果に含むとなると、Findでは無理で関数を自作することになりますが、これは必要ですか。その場合、どこまで一致すれば、一致とみなすのかの基準を明確にする必要もあります。

[COFFEE.Inc]

大変失礼しました。おっしゃる通りでりんご缶はりんごジュースの一部ではないので、検索結果としては隣の列に値を入れないです。出力例が間違っており恐縮です。

[moh1ee]

予想ですが、A列を「りんご」で検索して「りんごジュース」が見つかったら、次に「りんごジュース」を検索値としてA列を検索して「リンゴジュース１ダース」を見つける。検索結果が返らなくなったら元の検索値「りんご」の右に「りんごジュース」「りんごジュース１ダース」を書き込む。というようなイメージで合っていますか？これならFind関数で対応可能ですが、文面通りですと「りんごジュース」で探して「リンゴ」を見つける様なことになり、上で指摘のあったように自作することになります。

[COFFEE.Inc]

ご指摘ありがとうございます。実現したいこととしては、りんごで検索して、部分一致かつ、単語が長いものである(先ほどは単語が短いとしておりました。申し訳ないです。)、りんごジュースや、りんごジュース1ダースがヒットすると思うので、そのヒットしたものをりんごの隣の列に並べるイメージです。りんごが全て完了したら、下の行に移動し、りんごジュースで検索をかけ、りんごジュースよりも長い言葉であるりんごジュース１ダースがヒットするので、りんごジュースの隣にりんごジュース1ダースが入るイメージです。その場合は、Find関数の部分一致と単語の長さを条件に実現できるのではないかと思っていました。こちらocdpdcoさんの理解と同じでしょうか。認識の齟齬があリましたら、こちらの説明不足で大変申し訳ないです。

Answer 1

ご提示のコードを根本的に否定する回答で申し訳ないですが、あまり小難しく考えずに、次のような構成にするとわかりやすいと思います。
実装はお任せします。

For 検索対象行=1 To 行の終わりまで
  For 検索行=1 To 行の終わりまで
    列変数 = 2 ' B列から
    If 検索対象セルと検索セルが希望条件 Then
      検索対象行と列変数のセルに検索行のセルをコピー
      列変数をインクリメント
    End If
  Next
Next

Answer 2

hatena19さんとほぼ同じ回答ですが投稿しちゃいます。

①はループ処理で実現できないでしょうか？
（例）RangeではなくCellsを使う。（変数iが増える＝列が下方向へずれる）

Dim i As Long
For i = 1 To 5000
    Set Target = Cells(1, i)
    '検索処理
Next

②はDoループの中のNothingかを判定しているIF文の後に入れれば良いと思います。
（Nothingではない＝検索結果の文字数を取ることができる）

③は少し厄介ですが、検索値がある行の最終列（Cells(Target.Row, Columns.Count)）から見て
最初に発見した左端のセル（End(xlToLeft）の1つ右のセル（Offset(0, 1)）という取得の仕方が
一般的（？）です。

これは右端のセル（XFD列）で「Ctrl + ←」を押した後に「→」を押す動作をマクロ化したものです。
実際に手作業で確認すれば理解が深まるかと思います。
【参考サイト】

'②検索値よりも長い場合
If Len(c.Value) > Len(searchWord) Then
    '③空いている列に追加する
    Cells(Target.Row, Columns.Count).End(xlToLeft).Offset(0, 1).Value = c.Value
End If

Answer 3

①：検索値を下方向へずらしていく。Offsetで可能？

Offsetでもいいですが、 Cells(i, 1).Value とした方が分かりやすいのでは。
i は For Nextで一つずつ増やしていきます。

②：検索条件として、検索値よりも長い単語を検索結果としたい場合、どこに条件をいれるのがいいのか。

Findメソッドの引数で、LookAt:=xlPartとすれば部分一致になります。検索対象に検索値が部分一致するいう意味ですので、検索値より短い単語は引っ掛かりません。これで、検索対象の方が長いというのは保証されます。

③：検索結果としてヒットした単語の隣の行に検索値を与える。B列が埋まっている場合は、C列にというやり方がわかりません。。。

Cells(i, Columns.Count).End(xlToLeft).Column で入力してある最終列を取得できますので、
その列数分Offsetして代入すればいいでしょう。

上記を考慮して、サンプルコードを作成してみました。
データの入力してあるシートのモジュールに下記のコードを記述してください。

Public Sub FindTest()
    Dim c As Range
    Dim searchWord As String
    Dim firstAddress As String
    Dim i As Long

    With UsedRange.Columns(1)    'A列を検索対象
        For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
            searchWord = Cells(i, 1).Value
            Set c = .Find(What:=searchWord, LookIn:=xlValues, _
                          LookAt:=xlPart)    '部分一致で検索

            '条件に当てはまるセルがあるかどうかを判定
            If Not c Is Nothing Then
                '最初のセルのアドレスを覚える
                firstAddress = c.Address

                '繰返し検索し、条件を満たすすべてのセルを検索する
                Do
                    If c.Value <> searchWord Then
                        Cells(i, Cells(i, Columns.Count).End(xlToLeft).Column + 1) _
                                = c.Value
                    End If
                    Set c = .FindNext(c)
                    If c Is Nothing Then Exit Do
                Loop Until c.Address = firstAddress
            End If
        Next
    End With
End Sub

追記

ただしFindメソッドは遅いので、データ数が多い場合は、検索対象範囲を配列に入れて、 For Nextでループしながら、Like演算子で部分一致比較をすると高速になります。

Public Sub ArrayLikeTest()
    Dim aryA() As Variant
    Dim aryMatch() As Variant, c As Long
    Dim searchWord As String
    Dim i As Long, j As Long

    aryA = UsedRange.Columns(1).Value 'A列を配列に
    For i = 1 To UBound(aryA)
        searchWord = aryA(i, 1)
        c = -1
        For j = 1 To UBound(aryA)
            If i <> j Then
                If aryA(j, 1) Like "*" & searchWord & "*" Then '部分一致比較
                    c = c + 1
                    ReDim Preserve aryMatch(c)
                    aryMatch(c) = aryA(j, 1) '検索結果を配列に格納
                End If
            End If
        Next j
        If c >= 0 Then
            Range(Cells(i, 2), Cells(i, c + 2)).Value = aryMatch
        End If
        ReDim aryMatch(0) '配列を初期化
    Next i

End Sub

Comments

[COFFEE.Inc]

とても丁寧にかつ、迅速に回答していただき、
本当にありがとうございました。

また、追記に高速にするやり方も勉強になりました。
今回提示していただいたサンプルコードをもとに勉強させていただきます。
がんばります！！