エクセルVBA 検索とデータ保持の手順

質問

表題が何と記載すれば良いか分からなかったので曖昧な表題となってしまい
申し訳ございません。
今回は自分的には高度でどの様にしたら良いかが分からず質問させて頂きます。

シートAとシートBとシートC　及び　項目一覧シートがあると仮定します。
シートA（検索対象シート）　　　A~D列程度あり、行数は2000行程度を想定
シートB（ピックアップシート）　A~D列程度あり、行数は2000行程度を想定
項目一覧シート（シートAの項目）開発に関する文字列
　　　　（JavaとかPHPとかの一覧になります。なので、項目数は多く２００位でしょうか？）
シートC（書き出しシート）
（こんな感じかなと）

１．シートAのC列セル内の文字（凡そ2000文字程度入力があります）内に
　　項目一覧シートに羅列している文字列が含まれているかを検索。
　　含まれている文字列を取得し（ヒットした文字列全て）ます。
　　この時、複数の文字列を取得する事を想定します。
２．シートBのC列セル内の文字（こちらも2000文字程度が入力）内に
　　含まれている文字列から、先程取得した文字列があるかを検索。
　　２つ以上含まれていたら抽出する。
　　シートCに対象となった、シートAのA~D列の全ての行を転記、ヒットした
　　シートBのA~D列の全ての行を転記。
　　上記をシートBの入力がある全てのセルに行う。

上記を行いたいです。
ここからがデータの持ち方になるのですが、以下の感じで良いのか。。。

A2ｌB2ｌC2ｌD2　　←　シートAから抽出したデータ
　　A100ｌB100ｌC100ｌD100
　　A189ｌB189ｌC189ｌD189
　　A1351ｌB1351ｌC1351ｌD1351　←　シートBから抽出したデータ
↑一つセルを開けるイメージです。

上記をツリー型と言うのでしょうか？ぶら下型と言った方が良いのかな？として表記させて
頂きました。
但し、エクセルのつくり上とかなどで上記はやめた方が良い場合には、お手数ですが
ご教授頂けると助かります。

シートAのC列には以下の様な内容が記載あります。（内容は適当に端折ってます）
------------------------------------------------------------------------------------------------------------
【作業内容】
広告媒体を管理するツール（Webツール）の開発
・広告効果測定ツールとのAPI繋ぎ込みによるデータ取得
・広告媒体とのAPI繋ぎ込みによるデータ取得
【要件スキル】
≪求めるスキル≫
・PHP／Javascriptを用いたWEBアプリケーション
・MySQLを使用した開発経験
≪ 歓迎するスキル ≫
・広告業界での開発経験
・PHPフレームワークやCSSフレームワークを使用した開発経験
≪ 人物像 ≫
・ゲームが好きな方

----------------------------------------------------------------
シートBのC列には以下の様な内容があります。
------------------------------------------------------------------------------------------------------------
■氏名：
■所属：
■開発経験：20年
■スキル：
【スキル面】
基本設計～製造
VB, Java, C, PHP, HTML, JavaScript
IBM Notes, SQLServer, MySQL, SQL
【人物面】
コミュニケーション能力高めです。
■補足：PHPは1ヶ月程度の製造経験。VBとJavaScriptが得意。

------------------------------------------------------------------------------------------------------------

上記の場合は、PHPとJavaScriptがヒットするので、シートCへの転記をする。
（シートAのA-D列を抽出し（仮にAとします）、シートCへ転記。
及びヒットしたシートBのA-D列を抽出し（仮にBとします）、Aの下部へ転記。
複数ヒットの場合は、順次Bの下部へ転記していく）

上記の様な事はエクセルで可能でしょうか？（何とかエクセルで作り上げたいのですが。。）
宜しくお願い致します。

回答No.2

ushi2015 · ベストアンサー

こんにちは
先ほど回答したつもりでしたが消えている(ΘoΘ;)
Sub test1()
　　Dim shA As Worksheet
　　Dim shB As Worksheet
　　Dim shC As Worksheet
　　Dim shK As Worksheet
　　Dim shT As Worksheet
　　Dim r As Range
　　Dim s As Range
　　Dim t As Range
　　Dim v As Range
　　Dim h As Long
　　Dim i As Long
　　Dim j As Long
　　Dim k As Long
　　Set shA = Worksheets("A")
　　shA.Copy shA
　　Set shT = ActiveSheet
　　Set shB = Worksheets("B")
　　Set shC = Worksheets("C")
　　Set shK = Worksheets("項目一覧")
　　Application.ScreenUpdating = False
'　　シートAのC列セル内の文字（凡そ2000文字程度入力があります）内に
'　　項目一覧シートに羅列している文字列が含まれているかを検索。
'　　含まれている文字列を取得しシートAのコピーシートのE列以降に羅列
　　For Each r In shT.Range("A1").CurrentRegion.Columns(3).Cells
　　　　j = 2
　　　　For Each t In shK.Range("A1").CurrentRegion.Columns(1).Cells
　　　　　　If InStr(1, r, t) > 0 Then
　　　　　　　　r.Offset(, j) = t
　　　　　　　　j = j + 1
　　　　　　End If
　　　　Next
　　Next
　　h = 2 'シートCの2行目から
'　　コピーシートのE列を順次処理
　　For Each r In shT.Range("A1").CurrentRegion.Columns(5).Cells
　　　　On Error Resume Next
'　　　　シートAのコピーシートのE列以降に羅列したデータを取得
　　　　Set v = shT.Range(r, r.End(xlToRight)).SpecialCells(xlCellTypeConstants)
　　　　If Err.Number <> 0 Then Set v = Nothing
　　　　On Error GoTo 0 'On Error Resume Next の対になるコード（エラー回避解除）
　　　　j = 0
'　　　　シートAのコピーシートのE列以降に羅列したデータの有無確認
　　　　If Not v Is Nothing Then
'　　　　シートAのコピーシートのE列以降に羅列したデータ数の50%位
　　　　　　k = Int(v.Cells.Count / 2)

'　　　　　　順次処理しているE列の左4セルはA列
'　　　　　　4列分にリサイズ（例：A2:D2）したものをコピーして
'　　　　　　シートCのセル位置、h行目の1列目に貼り付け
　　　　　　r.Offset(, -4).Resize(, 4).Copy shC.Cells(h, 1)

　　　　　　For Each s In shB.Range("A1").CurrentRegion.Columns(3).Cells
　　　　　　　　For Each t In v
　　　　　　　　　　If InStr(1, s, t) > 0 Then
　　　　　　　　　　　　j = j + 1
　　　　　　　　　　　　If j > k Then Exit For
　　　　　　　　　　End If
　　　　　　　　Next
　　　　　　　　If j > k Then
　　　　　　　　　　h = h + 1
'　　　　　　　　　　上記をツリー型
'　　　　　　　　　　を実現するために、shC.Cells(h, 2)で2列目を指定する
　　　　　　　　　　s.Offset(, -2).Resize(, 4).Copy shC.Cells(h, 2)
　　　　　　　　End If
　　　　　　　　j = 0
　　　　　　Next
　　　　End If
　　Next
　　Application.DisplayAlerts = False
　　shT.Delete
　　Application.DisplayAlerts = True
　　Application.ScreenUpdating = True
End Sub
で、どうでしょうか？

お礼

週末まで今回のシステムに取り掛かっていたのですが、どうしても解決
出来ないのが、補足事項はほぼ解決したのですが「ヒット率の向上」の
だけが解決できずに悩んでおります。

例）
・シートAに「Java、PMO、保険、金融」がキーワードになっていた場合
⇒　シートB内の対象列から上記キーワードが入っているセルを検索。
５０％以上のヒット率となると、「Java、PMO、保険、金融」の内
２つ以上がシートBの対象列にヒットしたら抽出する。
（１つだった場合は対象外とする）
※シートAのキーワードが１つだった場合は、シートBに対象キーワードが
　１つでも入っていた場合は、１００％になるので抽出する。

上記の形にしたいと考えております。
頂戴している
'シートAのコピーシートのE列以降に羅列したデータ数の50%位
k = Int(v.Cells.Count / 2)
上記ですが、どうしても理解が出来ず悩み続けております(^_^;)

お礼コメントにこの記載が合っているか分かりませんが、
何卒、宜しくお願い致します。

補足

まだデバック中ですが、一点まず最初に気になっているのが
For Each r In shT.Range("A2").CurrentRegion.Columns(4).Cells
j = 2
For Each t In shK.Range("A1").CurrentRegion.Columns(1).Cells
If InStr(1, r, t) > 0 Then
r.Offset(, j) = t
j = j + 1
End If
Next
Next

上記（及び　ｔ　もですが）一行目から検索を掛けてしまうので
表題について検索をしてしまっております。
（対して問題無いのであまり気にしなくても良いでしょうけど。。）

一点問題点が出たのですが、上記の通り表題があるのですが
r.Offset(, -4).Resize(, 4).Copy shC.Cells(h, 1)
上記で実行すると表題がシートCにコピーされてしまいます。
r.Offset(1, -4).Resize(, 4).Copy shC.Cells(h, 1)
上記の様にした所、検索値自体にミスマッチが起っておりそうです。。。

'シートAのコピーシートのE列以降に羅列したデータ数の50%位
k = Int(v.Cells.Count / 2)

上記ですが、シートBのヒット率５０％以上となっているのでしょうか？
例えばシートAの検索値が「Java、PMO、保険、金融」となっていた場合、
シートBのセルに２項目程度（例えばJavaとPMO）以上がシートBのセル内
に含まれていれば転記を行うって形にしたいです。

※また、当該処理を行っていた際に思い付いてしまったのですが、
検索元データ（コピーシートの５列目以降に出力されているキーワード）も
シートCに一緒に転記出来る様にしたいです。

上記で質問の意図が伝われば良いのですが(^_^;)

回答No.3

ushi2015

こんにちは
お昼に回答したつもりでしたが消えている(ΘoΘ;)
確認の後の回答するボタンを押し忘れてる・・・
戻ると回答するボタンは上に表示してあればいいのに。
Sub test2()
　　Dim shA As Worksheet
　　Dim shB As Worksheet
　　Dim shC As Worksheet
　　Dim shK As Worksheet
　　Dim shT As Worksheet
　　Dim r As Range
　　Dim s As Range
　　Dim t As Range
　　Dim v As Range
　　Dim h As Long
　　Dim i As Long
　　Dim j As Long
　　Dim k As Long
　　Set shA = Worksheets("A")
　　shA.Copy shA
　　Set shT = ActiveSheet
　　Set shB = Worksheets("B")
　　Set shC = Worksheets("C")
　　Set shK = Worksheets("項目一覧")
　　Application.ScreenUpdating = False
　　シートAのC列セル内の文字（凡そ2000文字程度入力があります）内に
　　項目一覧シートに羅列している文字列が含まれているかを検索。
　　含まれている文字列を取得しシートAのコピーシートのE列以降に羅列
　　For Each r In shT.Range("A1").CurrentRegion.Columns(3).Cells
　　　　If r.Row > 1 Then
　　　　　　j = 2
　　　　　　For Each t In shK.Range("A1").CurrentRegion.Columns(1).Cells
　　　　　　　　If t.Row > 1 Then
　　　　　　　　　　If InStr(1, r, t) > 0 Then
　　　　　　　　　　　　r.Offset(, j) = t
　　　　　　　　　　　　j = j + 1
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　Next
　　　　End If
　　Next
　　コピーシートのE列を順次処理
　　For Each r In shT.Range("A1").CurrentRegion.Columns(5).Cells
　　　　If r.Row > 1 Then
　　　　　　On Error Resume Next
　　　　　　シートAのコピーシートのE列以降に羅列したデータを取得
　　　　　　Set v = shT.Range(r, r.End(xlToRight)).SpecialCells(xlCellTypeConstants)
　　　　　　If Err.Number <> 0 Then Set v = Nothing
　　　　　　On Error GoTo 0 'On Error Resume Next の対になるコード（エラー回避解除）
　　　　　　j = 0
　　　　　　シートAのコピーシートのE列以降に羅列したデータの有無確認
　　　　　　If Not v Is Nothing Then
　　　　　　シートAのコピーシートのE列以降に羅列したデータ数の50%の小数点以下第一位を四捨五入
　　　　　　　　k = WorksheetFunction.RoundUp(v.Cells.Count / 2, 0)
　　　　　　　　Debug.Print k
　　　　　　　　順次処理しているE列の左4セルはA列
　　　　　　　　4列分にリサイズ（例：A2:D2）したものをコピーして
　　　　　　　　シートCのセル位置、h行目の1列目に貼り付け
　　　　　　　　h = shC.Cells(Rows.Count, 2).End(xlUp).Row + 1
　　　　　　　　r.EntireRow.Copy shC.Cells(h, 1)

　　　　　　　　For Each s In shB.Range("A1").CurrentRegion.Columns(3).Cells
　　　　　　　　　　If s.Row > 1 Then
　　　　　　　　　　　　For Each t In v
　　　　　　　　　　　　　　If InStr(1, s, t) > 0 Then
　　　　　　　　　　　　　　　　j = j + 1
　　　　　　　　　　　　　　　　If j >= k Then Exit For
　　　　　　　　　　　　　　End If
　　　　　　　　　　　　Next
　　　　　　　　　　　　If j >= k Then
　　　　　　　　　　　　　　h = h + 1
　　'　　　　　　　　　　　　上記をツリー型
　　'　　　　　　　　　　　　を実現するために、shC.Cells(h, 2)で2列目を指定する
　　　　　　　　　　　　　　s.Offset(, -2).Resize(, 4).Copy shC.Cells(h, 2)
　　　　　　　　　　　　End If
　　　　　　　　　　End If
　　　　　　　　　　j = 0
　　　　　　　　Next
　　　　　　End If
　　　　End If
　　Next
　　Application.DisplayAlerts = False
　　shT.Delete
　　Application.DisplayAlerts = True
　　Application.ScreenUpdating = True
End Sub

回答No.1

ushi2015

こんにちは
【作業内容】以下、■氏名：以下はそれぞれ1セルの内容でしょうか？
Sub test()
　　Dim shA As Worksheet
　　Dim shB As Worksheet
　　Dim shC As Worksheet
　　Dim shK As Worksheet
　　Dim shT As Worksheet
　　Dim r As Range
　　Dim s As Range
　　Dim t As Range
　　Dim v As Range
　　Dim h As Long
　　Dim i As Long
　　Dim j As Long
　　Set shA = Worksheets("A")
　　shA.Copy shA
　　Set shT = ActiveSheet
　　Set shB = Worksheets("B")
　　Set shC = Worksheets("C")
　　Set shK = Worksheets("項目一覧")
　　Application.ScreenUpdating = False
　　For Each r In shT.Range("A1").CurrentRegion.Columns(3).Cells
　　　　j = 2
　　　　For Each t In shK.Range("A1").CurrentRegion.Columns(1).Cells
　　　　　　If InStr(1, r, t) > 0 Then
　　　　　　　　r.Offset(, j) = t
　　　　　　　　j = j + 1
　　　　　　End If
　　　　Next
　　Next
　　h = 1
　　For Each r In shT.Range("A1").CurrentRegion.Columns(5).Cells
　　　　On Error Resume Next
　　　　Set v = shT.Range(r, r.End(xlToRight)).SpecialCells(xlCellTypeConstants)
　　　　If Err.Number <> 0 Then Set v = Nothing
　　　　On Error GoTo 0
　　　　j = 0
　　　　If Not v Is Nothing Then
　　　　　　r.Offset(, -4).Resize(, 4).Copy shC.Cells(h, 1)
　　　　　　For Each s In shB.Range("A1").CurrentRegion.Columns(3).Cells
　　　　　　　　For Each t In v
　　　　　　　　　　If InStr(1, s, t) > 0 Then
　　　　　　　　　　　　j = j + 1
　　　　　　　　　　　　If j = 2 Then Exit For
　　　　　　　　　　End If
　　　　　　　　Next
　　　　　　　　If j = 2 Then
　　　　　　　　　　h = h + 1
　　　　　　　　　　s.Offset(, -2).Resize(, 4).Copy shC.Cells(h, 2)
　　　　　　　　End If
　　　　　　　　j = 0
　　　　　　Next
　　　　End If
　　Next
　　Application.DisplayAlerts = False
　　shT.Delete
　　Application.DisplayAlerts = True
　　Application.ScreenUpdating = True
End Sub
2000行×2000行×項目数200、のチェックなので相当時間が掛かるかと思います。

お礼

もう一点ですが、キーワードを増やしている所ヒット率が急激に上がって
しまいまして、５０％以上ヒットしている場合と条件を付ける事は可能で
しょうか？

宜しくお願い致します。

補足

回答が遅くなりました。
頂戴したコードの読み込み（理解）を図っていたのですが、
以下の部分がどうしても分からなく、解説をお願いしたいのですが。。。
それと、Cシートへの書き込みですが、１行目は表題としたいのですが
何処をいじると２行目以降に記載されるかがわからず、そちらも教えて
頂けると助かります。
下記コードより上のコードについては、何とか理解したつもりです(^_^;)

For Each r In shT.Range("A1").CurrentRegion.Columns(5).Cells
On Error Resume Next
Set v = shT.Range(r, r.End(xlToRight)).SpecialCells(xlCellTypeConstants)
'// 右方向の最終列までをセット

If Err.Number <> 0 Then Set v = Nothing
↑恐らくOnErrorResumeの部分でエラーになってなければの条件式かと

On Error GoTo 0
　↑GoTo 0の行先が分からないです。。。

j = 0
If Not v Is Nothing Then
　↑最終行まで処理が行われたら？って意味でしょうか？

r.Offset(, -4).Resize(, 4).Copy shC.Cells(h, 1)
★↑上記が一番理解出来ない部分です。
　　検索地ｒの左４列目。。。
　　Resizeはセルの行幅を変えるって意味ですか？
　　空白を挟んでshC.Cells(h,1)これも分からずでして。。

For Each s In shB.Range("A1").CurrentRegion.Columns(4).Cells
For Each t In v
If InStr(1, s, t) > 0 Then　←　ヒットした文字列があった場合
j = j + 1　　　　　　　　　　Jに加算していく。
If j = 2 Then Exit For　　　
　　End If
Next

If j = 2 Then
h = h + 1
s.Offset(, -2).Resize(, 4).Copy shC.Cells(h, 2)
End If
j = 0
Next
End If
Next

質問出来る部分がここまでしか出来ない状態ですが、
まずはここまでご教授お願いします！