vbaリストと同じ値があったら、隣のセルに値を反映

質問

エクセル　マクロ(vba)の質問です。

a列に検索リストがあり、b列に検索対象があります。
このとき、a列の検索リストと合致した文字のみをb列から取り出し、c列に反映させたいです。

以下のコードを走らせましたが、何も起こらず、どこを修正すればいいのか困っています。

お手数ですが、ご教示いただけますと幸いですm(_ _)m

dim i as long

for i = 1 to cells(rows.count,1).end(xlup).row

if Instr(cells(i,2),cells(i,1)) then
cells(i,3) = cells(i,1)
i = i + 1

end if

next

回答No.3

kkkkkm · ベストアンサー

No.1の訂正です。

> 今日は晴れでした。売上アップ
> だと、結果は
> 売上晴れ

だと結果で文字列の区切りが分からないので

「,」で区切る場合(c列に反映を守る)

Sub Test2()
Dim i As Long, j As Long
Dim mRow As Long

mRow = Cells(Rows.Count, 2).End(xlUp).Row
Range(Cells(1, "C"), Cells(mRow, "C")).ClearContents

For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
For j = 2 To mRow
If InStr(Cells(j, 2), Cells(i, 1)) Then
If Cells(j, 3) <> "" Then
Cells(j, 3) = Cells(j, 3) & "," & Cells(i, 1)
Else
Cells(j, 3) = Cells(i, 1)
End If
End If
Next
Next
End Sub

c列に反映を守らなくて見つけた文字列分右のセルに追加していく場合

Sub Test3()
Dim i As Long, j As Long, rp() As Long
Dim mRow As Long

mRow = Cells(Rows.Count, 2).End(xlUp).Row
Range(Cells(1, "C"), Cells(mRow, "C")).ClearContents
ReDim rp(mRow)

For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
For j = 2 To mRow
If InStr(Cells(j, 2), Cells(i, 1)) Then
Cells(j, 3).Offset(0, rp(j)) = Cells(i, 1)
rp(j) = rp(j) + 1
End If
Next
Next
End Sub

お礼

遅くなり、申し訳ありません。

本当に助かりました！ありがとうございました！

回答No.2

imogasi

模擬例でも挙げてもらわないと、質問のケースがよく判らない。
勝手に想像して、やった。
下記の例なら、ＶＢＡ関数のＩｎｓｔｒ利用でも、出来るが。
意味は、B列の文章の中に、A列の語句があれば、C列以右列に書き出す。
例データ　A1:B6
山田　背の高い上野の身長 上野
北野 　近藤の英語の成績 近藤
上野 　大きな山の田んぼ
近藤 　あの北野の話は長い 北野
　山の雪が溶けだした
　北野と近藤とどっちが背が高い 北野　近藤
コード
Sub test01()
lrB = Cells(10000, "B").End(xlUp).Row
lrA = Cells(10000, "A").End(xlUp).Row
'---
For i = 1 To lrB
k = 3
For j = 1 To lrA
Set f = Cells(i, "B").Find(what:=Cells(j, "A"))
If Not f Is Nothing Then Cells(i, k) = Cells(j, "A"): k = k + 1
Next j
Next i
End Sub

回答No.1

kkkkkm

合致が2個以上あった場合にも反映します。
たとえばB3が
今日は晴れでした。売上アップ
だと、結果は
売上晴れ
となります。

Sub Test()
Dim i As Long, j As Long
Dim mRow As Long

mRow = Cells(Rows.Count, 2).End(xlUp).Row
Range(Cells(1, "C"), Cells(mRow, "C")).ClearContents

For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
For j = 2 To mRow
If InStr(Cells(j, 2), Cells(i, 1)) Then
Cells(j, 3) = Cells(j, 3) & Cells(i, 1)
End If
Next
Next
End Sub