Excel VBAで文字列の部分一致の文字列を表示

質問

以前、こちらで頭５文字までの一致で文字列を表示するVBAを教えて頂きました。今回はFINDなどの部分一致での文字列を表示することをしたいのですが、ご教示いただけますと幸いです。

下記はSheet1のA3に文字を5文字以内いれるとSheet２のC列からピックアップしてSheet１のA列に文字列を表示する及びSheet２のB列のデータをSheet１のC列に表示させるVBAです。

Sub Test2()
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim SData As String, i As Long, VRet As Variant
Dim c As Range, LastRow As Long

Set Ws1 = Sheets("Sheet1")
Set Ws2 = Sheets("Sheet2")

SData = CStr(Ws1.Range("A3").Value)
If SData = "" Then Exit Sub
i = 5
LastRow = Ws1.Cells(Rows.Count, "A").End(xlUp).Row
If LastRow < i Then
LastRow = i
End If
Ws1.Range(Ws1.Cells(i, "A"), Ws1.Cells(LastRow, "C")).ClearContents
With Ws2
For Each c In .Range(.Cells(1, "C"), .Cells(Rows.Count, "C").End(xlUp))
VRet = InStr(1, CStr(c.Value), SData, vbTextCompare)
If VRet = 1 And Len(c.Value) >= 10 Then
Ws1.Cells(i, "A").Resize(1, 2).Value = c.Resize(1, 2).Value
'とりあえずSheet2のB列のデータ(C列のデータに同期したデータ)をSheet1のC列に
Ws1.Cells(i, "C").Value = .Cells(c.Row, "B").Value
i = i + 1
End If
Next
End With
End Sub

宜しくお願い致します。

回答No.3

kkkkkm · ベストアンサー

> PDFを検索する時に例えばDeepPlanFilmeのように一文字づつではなく

いまいち、これの意味が分かりませんが(元のコードは一文字づつ検索しているわけではないので)

> FreePDFActionのようにA3の文字列(PDF)がくっついているもの

A3がPDFだったら FreePDFAction、 PDFActionabcd、 abcdFreePDFなど10文字以上の文字列がヒットすると思いますが。

PDFActionは10文字以下なのでヒットしない。

補足

A3: PDF ←入力

A5: CD Manipulator
A6: DeepBurner v1.8.0.224
A7: DeepBurner v1.9.0.228
A8: Free Create-Burn ISO Image v2.0
A9: Free ISO Creator version 2.8
　　　　　　・
　　　　　　・
　　　　　　・
こんな感じで表示されます。半角スペースがあるせいでしょうか？
何度もすみません。

回答No.5

kkkkkm

> こんな感じで表示されます。半角スペースがあるせいでしょうか？

その文字列全てヒットしないはずですが。

If VRet > 0
じゃなくて
If VRet >= 0
か
If VRet = 0
になっていませんか。これだとヒット関係なく10文字以上の文字列は全て表示されます。

回答No.4

kkkkkm

No3　訂正
PDFActionは10文字以下なのでヒットしない。
↓
PDFActionは10文字未満なのでヒットしない。

回答No.2

imogasi

プログラムの質問などするとき、過去の自分が使った（考えた、学んだ）コードなど、挙げないで、虚心に、WEBで、適当な、熟語を連ねて調べて（例　vba find 部分一致）、その載っている例について、どこをどう変えるべきか質問したほうがよかろう。
それより、適当なサンプルと結果を質問に、上げてもらった方が増しだ。
本件質問も文章だけで、サンプルがない。
ーー
Findを使うの例は参考に上げてみる。

前回の質問では、各セルを舐めて処理するやり方だったのだろうが、それに曳きづられた回答が出ている。
Findはコード的には、１セルづつ、なめる形ではない。
ーー
例データ
A2:A6
エンジン不調で実行中止した
点火装置が不調らしく、エンジニアに修理を頼んだ
エンジ色の服がかかっていた
エンコしたので歩いた
オレンジ色の服が好きらしい
ーー
検索語は「エンジ」とした。部分一致を探す。変な例ですみません。
街灯語句の箇所に文字色を付けた。
別セルにセル全文を持ってくるのは、変更はたやすいのでこのようにしてみた。
ーー
WEBのコードを借用し２つを組みあわせたので、不自然なところあるが、すみません。
標準モジュールに
Sub macro2()
Dim myRange As Range
Dim myObj As Range
Dim keyWord As String

Set myRange = Range("A1:A5")
keyWord = "エンジ"
Set myObj = myRange.Find(keyWord, LookAt:=xlPart)

If myObj Is Nothing Then
MsgBox "'" & keyWord & "'はありませんでした"
Else
MsgBox "'" & keyWord & "'は" & myObj.Row & "行目にあります"
iposition = InStr(myObj, keyWord)
myObj.Characters(Start:=iposition, Length:=Len(keyWord)).Font.Color = vbRed
End If
Set StartRange = myObj '最初に見つかったセルを格納しておく
'---
Do

Set myObj = Range("A1:A5").FindNext(myObj) '次の検索セルを指定する

If myObj.Address = StartRange.Address Then '見つかったセルが最初のセルか判定

Exit Do '同じ場合はループを離脱
Else
MsgBox myObj.Row
iposition = InStr(myObj, keyWord)
myObj.Characters(Start:=iposition, Length:=Len(keyWord)).Font.Color = vbRed
End If
Loop
End Sub
ーー
セルの１部の文字エンジに、赤色がついているだろう。

回答No.1

kkkkkm

Sheet２のC列にA3の文字列が部分一致で含まれていたら、それぞれ今のコードと同じ列に転記させるのでしたら。
(10文字以上のデータ縛りありで)

If VRet = 1 And Len(c.Value) >= 10 Then
を
If VRet > 0 And Len(c.Value) >= 10 Then
に変更して試してみてください。

補足

A3の文字列ですが、PDFを検索する時に例えばDeepPlanFilmeのように一文字づつではなくFreePDFActionのようにA3の文字列(PDF)がくっついているものを検索したいです。
何卒宜しくお願い致します。