二つの条件に合致する製品を求めるマクロ

質問

以下のようなルールの製品固有の製造番号がある場合、会社名と製造番号から製品名を決定するマクロを組むにはどうしたらいいでしょうか。

会社名/製造番号/製品名
A/A1001,A1002…/パソコン
A/A2001,A2002…/モニター
B/001B1,002B1…/マウス
B/001B2,002B2…/キーボード
※A社を例にすると、A＊が製品の種類を特定し（A1=パソコン）、そのあとの3桁が製品の続き番号を示す。

会社名と製造番号がそれぞれA1、B1に記入してあるとすると、C1に製品名を書き込むステートメントを教えてください。
よろしくおねがいします。

回答No.9

kagakusuki · ベストアンサー

回答No.8の続きです。

With .Range(ProductColumnD & ItemRowD + 1 & ":" & ProductColumnD & LastRowD)

'「会社名」と「製造番号のパターン」が共に空欄の場合は何も表示せず、
'どちらか一方のみが空欄の場合はChr(7)の記号を表示し、
'両方ともに値が入力されている場合には、「『会社名』+Chr(7)の記号+『製造番号のパターン』」
'という形式の値を表示するワークシート関数を「製品名」を入力するためのセルに入力
.FormulaR1C1 = _
"=IF(OR(RC" & Columns(CompanyColumnD).Column & "="""",RC" _
& Columns(SerialColumnD).Column & "=""""),IF(AND(RC" & Columns(CompanyColumnD). _
Column & "="""",RC" & Columns(SerialColumnD).Column & "=""""),"""",CHAR(7)),RC" _
& Columns(CompanyColumnD).Column & "&CHAR(7)&RC" & Columns(SerialColumnD).Column & ")"

.Calculate '指定されたセル範囲のみ再計算を実行
.Value = .Value '「製品名」を入力するためのセルに、そのセルに入っている値を(ワークシート関数によらずに)入力(値のみコピー&貼り付けと同様の結果が得られる)
.Offset(, Columns(ColorColumnD).Column - Columns(ProductColumnD).Column).Value = .Value '「製品名」を入力するためのセルの値を、同じ行の「色」を入力するためのセルに入力
End With
End With

With PatternSheet

For i = ItemRowP + 1 To LastRowP '製造番号のパターンの一覧表におけるデータが入力されている行に対して繰り返し処理を行う
If .Range(CompanyColumnP & i).Value <> "" And .Range(SerialColumnP & i).Value <> "" Then 'もし「会社名」と「製造番号のパターン」に値が入力されている場合

'元データシートの製品名欄の列に対して、製造番号のパターンと一致する値を、それに対応する製品名に置換する
DataSheet.Range(ProductColumnD & ItemRowD + 1 & ":" & ProductColumnD & LastRowD).Replace _
What:=.Range(CompanyColumnP & i).Value & Chr(7) & .Range(SerialColumnP & i).Value, _
Replacement:=.Range(ProductColumnP & i).Value, LookAt:=xlWhole, SearchOrder:=xlByRows, _
MatchCase:=True, MatchByte:=False, SearchFormat:=False, ReplaceFormat:=False

'元データシートの色欄の列に対して、製造番号のパターンと一致する値を、それに対応する色の名称に置換する
DataSheet.Range(ColorColumnD & ItemRowD + 1 & ":" & ColorColumnD & LastRowD).Replace _
What:=.Range(CompanyColumnP & i).Value & Chr(7) & .Range(SerialColumnP & i).Value, _
Replacement:=.Range(ColorColumnP & i).Value

End If

Next i

'製造番号のパターンの一覧表に入力されているパターンと一致しない値を「(データ無し)」という文字列に置換し、
'該当するセルを黄色で塗り潰す
Application.ReplaceFormat.Clear
Application.ReplaceFormat.Interior.Color = 65535
DataSheet.Range(ProductColumnD & ItemRowD + 1 & ":" & ColorColumnD & LastRowD).Replace _
What:="*" & Chr(7) & "*", Replacement:="(データ無し)", LookAt:=xlWhole, MatchCase:=False, _
ReplaceFormat:=True

End With

labelE:
With Application

'置換機能のオプション設定をデフォルトに戻す
With .ReplaceFormat.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
.ReplaceFormat.Clear
ActiveSheet.Cells(1, 1).Replace _
What:="", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, _
MatchCase:=False, MatchByte:=False, SearchFormat:=False, ReplaceFormat:=False

.Calculation = xlAutomatic '計算モードを自動に切り替え
.ScreenUpdating = False 'モニター表示の更新を行う
End With

End Sub

　以上です。

お礼

ばっちりできました。本当に、本当に、心から感謝しております。
大変ありがとうございました。今後もアドバイスよろしくお願いします。

回答No.8

kagakusuki

>>製品名の右横に色を追加したいときにはどこをどうしたらよろしいのでしょうか。

>「右横」の件は唐突ですみません。右隣のセルという意味です。
>会社名/製造番号/製品名/色という配列になります。

　それでしたらまず、製造番号パターンシートのB列に入力する製造番号のパターンを、色の違いごとに対応する様に更に細分化したパターンを入力する様にして下さい。
　例えば仮の話として、A社の場合、

A1001-W
A1002-R
A1003-B

などの様に末尾に「-」付きで色を示す頭文字が記述されていて、「W」が白、「R」が赤、「B」が黒を示すというルールになっていたとします。
　一方、B社の場合は

002B1W
003B1B
004B1R

などの様に末尾にA社と同様の色を示す頭文字を付けるものの、「-」は付けないルールになっていたとします。
　その場合、製造番号パターンシートには

A列　　　　　B列　　　　C列　　　　D列
会社名 　　製造番号　　　製品名　　　色
A　　　　　A1???-W　　パソコン　　白
A　　　　　A1???-R　　パソコン　　赤
A　　　　　A1???-B　　パソコン　　黒
A　　　　　A1???-?　　パソコン　　(不明な色)
A　　　　　A1???　　　パソコン
B　　　　　???B1W　　　マウス　　　白
B　　　　　???B1R　　　マウス　　　赤
B　　　　　???B1B　　　マウス　　　黒
B　　　　　???B1?　　　マウス　　　(不明な色)
B　　　　　???B1　　　　マウス

等の様に入力しておき、その上で下記の様なVBAにされると良いと思います。
(細分化されたパターンの方を優先するために、B列の製造番号のパターンを降順で並べ替えるように変更しております)

Sub QNo9033500_二つの条件に合致する製品を求めるマクロ_色付き()

Const DataSheetName As String = "Sheet1" '元データが入力されているシートのシート名
Const PatternSheetName As String = "製造番号パターン" '製造番号のパターンの一覧表が入力されているシートのシート名
Const ItemRowD As Long = 2 '元データが入力されているシートにおいて実際のデータが入力されている行の1つ上の行の行番号
Const CompanyColumnD As String = "A" '元データが入力されているシートにおいて会社名が入力されている列
Const SerialColumnD As String = "B" '元データが入力されているシートにおいて製造番号が入力されている列
Const ProductColumnD As String = "C" '元データが入力されているシートにおいて製品名を書き込むための列
Const ColorColumnD As String = "D" '元データが入力されているシートにおいて製品の色を書き込むための列
Const ItemRowP As Long = 2 '製造番号のパターンの一覧表が入力されているシートにおいて実際のデータが入力されている行の1つ上の行の行番号
Const CompanyColumnP As String = "A" '製造番号のパターンの一覧表が入力されているシートにおいて会社名が入力されている列
Const SerialColumnP As String = "B" '製造番号のパターンの一覧表が入力されているシートにおいて製造番号のパターンが入力されている列
Const ProductColumnP As String = "C" '製造番号のパターンの一覧表が入力されているシートにおいて製品名が入力されている列
Const ColorColumnP As String = "D" '製造番号のパターンの一覧表が入力されているシートにおいて製品の色が入力されている列

Dim DataSheet As Worksheet, PatternSheet As Worksheet, _
LastRowD As Long, LastRowP As Long, c As Range, i As Long

'シートの有無を確認し、
'そのシートが存在している場合にはシートを変数に格納
'そのシートが存在していない場合にはマクロの実行を中止
If IsError(Evaluate("ROW('" & DataSheetName & "'!A1)")) Then
MsgBox "元データが入力されているシートとして設定されている" _
& vbCrLf & vbCrLf & DataSheetName & vbCrLf & vbCrLf & _
"というシート名のシートが見つかりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "存在しないシート"
Exit Sub
End If
Set DataSheet = Sheets(DataSheetName)
If IsError(Evaluate("ROW('" & PatternSheetName & "'!A1)")) Then
MsgBox "製造番号のパターンの一覧表が入力されているシートとして設定されている" _
& vbCrLf & vbCrLf & PatternSheetName & vbCrLf & vbCrLf & _
"というシート名のシートが見つかりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "存在しないシート"
Exit Sub
End If
Set PatternSheet = Sheets(PatternSheetName)

'処理を高速化するため自動で行われる処理の中で不要なものをOFF
With Application
.ScreenUpdating = False 'モニター表示の更新をしない
.Calculation = xlManual '計算モードを手動に切り替え
End With

With PatternSheet

'製造番号のパターンの一覧表が入力されているシートのデータを
'会社名を昇順、パターンを降順に並べ替え
.Sort.SortFields.Clear
.Range(CompanyColumnP & ItemRowP & ":" & ColorColumnP _
& .Cells.SpecialCells(xlCellTypeLastCell).Row).Sort _
Key1:=.Range(CompanyColumnP & ItemRowP), Order1:=xlAscending, _
Key2:=.Range(SerialColumnP & ItemRowP), Order2:=xlDescending, _
Header:=xlYes
.Sort.SortFields.Clear

'製造番号のパターンの一覧表が入力されているシートにおける
'データが入力されている最終行を取得
LastRowP = .Range(CompanyColumnP & .Rows.Count).End(xlUp).Row
If LastRowP <= ItemRowP Then
MsgBox "参照すべき製造番号のパターンのデータがありません。" _
& vbCrLf & "マクロを終了します。", vbExclamation, "データ無し"
GoTo labelE
End If

End With

With DataSheet

'元データが入力されているシートにおけるデータが入力されている最終行を取得
LastRowD = WorksheetFunction.Max(.Range(CompanyColumnD & .Rows.Count). _
End(xlUp).Row, .Range("B" & .Rows.Count).End(xlUp).Row)
If LastRowD <= ItemRowD Then
MsgBox "参照すべき元データがありません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "データ無し"
GoTo labelE
End If

※まだ途中なのですが、そろそろこの回答欄に入力可能な文字数の限界を超えそうですので、残りは又後で投稿致します。

回答No.7

kagakusuki

>製品名の右横に色を追加したいときにはどこをどうしたらよろしいのでしょうか。

との事ですが、ここまでのお話しの中で質問者様が示された例の中には、色に関する情報が1つも無いのですが、その色の情報は一体どこにどのような形で存在しているのでしょうか？
　又、「右横」とはどの様な意味で仰っておられるのでしょうか？
　もしかしますと、右隣のセルという意味なのでしょうか？

補足

「右横」の件は唐突ですみません。右隣のセルという意味です。
会社名/製造番号/製品名/色という配列になります。

回答No.6

piroin654

私が申し上げたいのは、この質問で提示されている
データの内容では法則は必要ない、ということに
なるのでは、ということです。

もし、質問が

会社名/製造番号/製品名
A/A1001,A1002…,A31001,A1003t,…/パソコン
A/A2001,A2002…/モニター
B/001B1,002B1…/マウス
B/001B2,002B2…/キーボード
　　　・
　　　・
　　　・

[パターンマッチデータ]
A　　A1　　パソコン
A　　A2　　モニタ
A　　A3　　ケーブル
B　　B1
　　　・
　　　・
　　　・
のようにデータが入り混じっているので、
これをパターンマッチデータを基に
何らかの処理をしたい、とかいうのならば
法則は必要になります。しかし、たとえば
A社のパソコンの行の製造番号データは
間違いがなく、他の行についても同様
というのであれば法則は
不必要ということになります。

質問が、
＞会社名と製造番号がそれぞれA1、B1に記入してあるとすると、
＞C1に製品名を書き込むステートメントを教えてください。
の一点ならば、単なる検索です。

実際のデータはどのようなものかはわかりませんが、
質問のデータで言えば、各社の製造番号が5桁で統一されている、
なんてことは到底ありえないし、製品の種類を特定する文字列が
都合よく先頭、あるいは末尾にあるというのも無理があります。
質問の意図が、
＞※A社を例にすると、A＊が製品の種類を特定し（A1=パソコン）、
＞そのあとの3桁が製品の続き番号を示す。
を一つの実例としてどうしても法則を使わなければ
ならないので、その方法を、というのであればそれなりの
質問データをだすべきだと思いますが。

反対に、法則を見つけたいというのであれば
それなりのデータ量とコード記述が必要になります。

回答No.5

piroin654

No1の、

Function funcStr(ByVal keyStr As String, ByVal myStr As String) As Boolean
　　Dim i As Long
　　Dim j As Long
　　Dim strArray As Variant

のところで、いらない変数の宣言をしていました。
　　Dim j As Long
はいりません。訂正を。

ところで、製造番号に何か法則があるのですかね。
＞※A社を例にすると、A＊が製品の種類を特定し（A1=パソコン）、
＞そのあとの3桁が製品の続き番号を示す。
A社についてはこのようにかかれていますが、B社については
何も書かれていないし、Ｂ社はA社の法則はあてはまらないし、
さらに他の会社があるのならばどのような法則かは
当然かかれていませんよね。
製造番号は一応、すべて5桁で表示されていますが、どこにも
5桁ですべて表示してあるとも書かれていなし、したがって
製造番号そのものの割り振りの法則は何もないのと同じですね。
したがって、B列にカンマ切りで製造番号が書かれているのならば、それを検索
すればいいだけですがね。

補足

B社について法則を記入せず申し訳ありません。B社は；

B＊が製品の種類を特定し（B1=マウス）、その前の3桁が製品の続き番号を示します。
それ以外については、自分で例を参考に直すしかないと思っております。

回答No.4

kagakusuki

回答No.3の続きです。

With DataSheet

'元データが入力されているシートにおけるデータが入力されている最終行を取得
LastRowD = WorksheetFunction.Max(.Range(CompanyColumnD & .Rows.Count). _
End(xlUp).Row, .Range("B" & .Rows.Count).End(xlUp).Row)
If LastRowD <= ItemRowD Then
MsgBox "参照すべき元データがありません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "データ無し"
GoTo labelE
End If

With .Range(ProductColumnD & ItemRowD + 1 & ":" & ProductColumnD & LastRowD)

'「会社名」と「製造番号のパターン」が共に空欄の場合は何も表示せず、
'どちらか一方のみが空欄の場合はChr(7)の記号を表示し、
'両方ともに値が入力されている場合には、「『会社名』+Chr(7)の記号+『製造番号のパターン』」
'という形式の値を表示するワークシート関数を入力
.FormulaR1C1 = _
"=IF(OR(RC" & Columns(CompanyColumnD).Column & "="""",RC" _
& Columns(SerialColumnD).Column & "=""""),IF(AND(RC" & Columns(CompanyColumnD). _
Column & "="""",RC" & Columns(SerialColumnD).Column & "=""""),"""",CHAR(7)),RC" _
& Columns(CompanyColumnD).Column & "&CHAR(7)&RC" & Columns(SerialColumnD).Column & ")"

.Calculate '指定されたセル範囲のみ再計算を実行
.Value = .Value '指定されたセル範囲の値を(ワークシート関数によらずに)セルに入っている値とする(値のみコピー&貼り付けと同様の結果が得られる)
End With
End With

With PatternSheet

'
For i = ItemRowP + 1 To LastRowP '製造番号のパターンの一覧表におけるデータが入力されている行に対して繰り返し処理を行う
If .Range(CompanyColumnP & i).Value <> "" And .Range(SerialColumnP & i).Value <> "" Then 'もし「会社名」と「製造番号のパターン」に値が入力されている場合

'元データシートの製品名欄の列に対して、製造番号のパターンと一致する値を、それに対応する製品名に置換する
DataSheet.Range(ProductColumnD & ItemRowD + 1 & ":" & ProductColumnD & LastRowD).Replace _
What:=.Range(CompanyColumnP & i).Value & Chr(7) & .Range(SerialColumnP & i).Value, _
Replacement:=.Range(ProductColumnP & i).Value, LookAt:=xlWhole, SearchOrder:=xlByRows, _
MatchCase:=True, MatchByte:=False, SearchFormat:=False, ReplaceFormat:=False
End If

Next i

'製造番号のパターンの一覧表に入力されているパターンと一致しない値を「(データ無し)」という文字列に置換し、
'該当するセルを黄色で塗り潰す
Application.ReplaceFormat.Clear
Application.ReplaceFormat.Interior.Color = 65535
DataSheet.Range(ProductColumnD & ItemRowD + 1 & ":" & ProductColumnD & LastRowD).Replace _
What:="*" & Chr(7) & "*", Replacement:="(データ無し)", LookAt:=xlWhole, MatchCase:=False, _
ReplaceFormat:=True

End With

labelE:
With Application

'置換機能のオプション設定をデフォルトに戻す
With .ReplaceFormat.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
.ReplaceFormat.Clear
ActiveSheet.Cells(1, 1).Replace _
What:="", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, _
MatchCase:=False, MatchByte:=False, SearchFormat:=False, ReplaceFormat:=False

.Calculation = xlAutomatic '計算モードを自動に切り替え
.ScreenUpdating = False 'モニター表示の更新を行う
End With

End Sub

　因みに、もしも元データの中に、製造番号のパターンの一覧表上に対応するパターンが無いものがあった場合には、Sheet1のC列上の該当するセルに「(データ無し)」と書き込んだ上で、目立たせるためにセルを黄色で塗り潰す様になっております。

お礼

丁寧な回答ありがとうございます。自分にとっては高度なものですので、じっくりやってみたいと思います。
これからもよろしくお願いします。

補足

一度「型が一致しません」エラーが出ましたが、解決しうまくいきました。
こんなに難しいステートメントになるとはつゆ知らず、気軽にお願いして大変恐縮に思っております。どうもありがとうございました。

再度のお願いで恐縮なのですが、製品名の右横に色を追加したいときにはどこをどうしたらよろしいのでしょうか。はじめは自分でできるかなと思ったのですが、とても無理そうなのでお願いする次第です。

回答No.3

kagakusuki

>以下のようなルール

に関してですが、新しいパターンの製造番号と製品名が追加されるたびに、一々マクロを修正していたのでは使い勝手が悪くなりますので、別シート上に「会社名」と「製造番号のパターン」及び「製品名」の関係をもらさず記載した一覧表を作っておき、マクロによる処理を行うと、その一覧表に記入しておいたパターンに合致する「会社名」と「製造番号」の組み合わせに対応する「製品名」を、元データの表のC列に入力するというやり方は如何でしょうか？

　例えば仮の話として、製造番号のパターンの一覧表を作成しておくシートのシート名を

製造番号パターン

であるものとします。
　そして

A/A1001,A1002…/パソコン

のパターンの場合は、
会社名である「A」を製造番号パターンシートのA3セルに、製品名である「パソコン
」をC3セルに入力し、
製造番号のパターンは「A1」+3文字ですから、製造番号パターンシートのB3セルには

A1???

という具合にワイルドカードを使用した形式で入力して下さい。
　同様に、A社のモニターの場合は

A2???

となりますし、B社のマウスの場合は

???B1

となります。(下の添付画像を参照して下さい)
　又、製造番号パターンシートの2行目には項目名を入力し、上記の様なデータを入力するのは3行目以下であるものとします。

　同様に、仮の話として

会社名/製造番号/製品名
A/A1001,A1002…/パソコン
A/A2001,A2002…/モニター
B/001B1,002B1…/マウス
B/001B2,002B2…/キーボード

といった元データが入力されているシートのシート名がSheet1であるものとし、そのA2セルに「会社名」、B2セルに「製造番号」、C2セルに「製品名」という具合に、2行目には項目名が入力されていて、実際のデータは3行目以下に入力されているものとします。

　上記のような前提条件の下で、Sheet1のC3以下に製品名を書き込むマクロは以下の様なものになります。

Sub QNo9033500_二つの条件に合致する製品を求めるマクロ()

Const DataSheetName As String = "Sheet1" '元データが入力されているシートのシート名
Const PatternSheetName As String = "製造番号パターン" '製造番号のパターンの一覧表が入力されているシートのシート名
Const ItemRowD As Long = 2 '元データが入力されているシートにおいて実際のデータが入力されている行の1つ上の行の行番号
Const CompanyColumnD As String = "A" '元データが入力されているシートにおいて会社名が入力されている列
Const SerialColumnD As String = "B" '元データが入力されているシートにおいて製造番号が入力されている列
Const ProductColumnD As String = "C" '元データが入力されているシートにおいて製品名が入力されている列
Const ItemRowP As Long = 2 '製造番号のパターンの一覧表が入力されているシートにおいて実際のデータが入力されている行の1つ上の行の行番号
Const CompanyColumnP As String = "A" '製造番号のパターンの一覧表が入力されているシートにおいて会社名が入力されている列
Const SerialColumnP As String = "B" '製造番号のパターンの一覧表が入力されているシートにおいて製造番号のパターンが入力されている列
Const ProductColumnP As String = "C" '製造番号のパターンの一覧表が入力されているシートにおいて製品名が入力されている列

Dim DataSheet As Worksheet, PatternSheet As Worksheet, _
LastRowD As Long, LastRowP As Long, c As Range, i As Long

'シートの有無を確認し、
'そのシートが存在している場合にはシートを変数に格納
'そのシートが存在していない場合にはマクロの実行を中止
If IsError(Evaluate("ROW('" & DataSheetName & "'!A1)")) Then
MsgBox "元データが入力されているシートとして設定されている" _
& vbCrLf & vbCrLf & DataSheetName & vbCrLf & vbCrLf & _
"というシート名のシートが見つかりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "存在しないシート"
Exit Sub
End If
Set DataSheet = Sheets(DataSheetName)
If IsError(Evaluate("ROW('" & PatternSheetName & "'!A1)")) Then
MsgBox "製造番号のパターンの一覧表が入力されているシートとして設定されている" _
& vbCrLf & vbCrLf & PatternSheetName & vbCrLf & vbCrLf & _
"というシート名のシートが見つかりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "存在しないシート"
Exit Sub
End If
Set PatternSheet = Sheets(PatternSheetName)

'処理を高速化するため自動で行われる処理の中で不要なものをOFF
With Application
.ScreenUpdating = False 'モニター表示の更新をしない
.Calculation = xlManual '計算モードを手動に切り替え
End With

With PatternSheet

'製造番号のパターンの一覧表が入力されているシートのデータを
'会社名順、パターン順に昇順に並べ替え
.Sort.SortFields.Clear
.Range(CompanyColumnP & ItemRowP & ":" & ProductColumnP _
& .Cells.SpecialCells(xlCellTypeLastCell).Row).Sort _
Key1:=.Range(CompanyColumnP & ItemRowP), Order1:=xlAscending, _
Key2:=.Range(SerialColumnP & ItemRowP), Order2:=xlAscending, _
Header:=xlYes
.Sort.SortFields.Clear

'製造番号のパターンの一覧表が入力されているシートにおける
'データが入力されている最終行を取得
LastRowP = .Range(CompanyColumnP & .Rows.Count).End(xlUp).Row
If LastRowP <= ItemRowP Then
MsgBox "参照すべき製造番号のパターンのデータがありません。" _
& vbCrLf & "マクロを終了します。", vbExclamation, "データ無し"
GoTo labelE
End If

End With

※まだ途中なのですが、そろそろこの回答欄に入力可能な文字数の限界を超えそうですので、残りは又後で投稿致します。

回答No.2

piroin654

No1です。訂正です。
回答の最後のあたりで、

結果は、

[sheet2]
A列　　　B列　　　　　C列
A　　　　A1003　　　　パソコン
B　　　　002B2　　　　キーボード
A　　　　A1001　　　　パソコン
A　　　　A1005　　　　該当無し
D　　　　005D2　　　　該当無し

のところで、[sheet2] としていますが、
[sheet1]です。

回答No.1

piroin654

＞※A社を例にすると、A＊が製品の種類を特定し（A1=パソコン）、
＞そのあとの3桁が製品の続き番号を示す。

Ｂ社にはあてはまっていないような・・・・。
法則がよくわかりませんが、一応shhet1に、

A列　　会社名
B列　　カンマ切りで製品番号
C列　　該当する製品

sheet2には、

A列　　会社名
B列　　製品番号

として、以下のように各sheetにデータがあるとします。

[sheet1]
A列　　　B列
A　　　　A1003
B　　　　002B2
A　　　　A1001
A　　　　A1005
D　　　　005D2

[sheet2]
A列　　　B列　　　　　　　　　　　　　　　　　　　　　　C列
A　　　　A1001,A1002,A1003,A1004　　　　　　　パソコン
A　　　　A2001,A2002,A003　　　　　　　　　　　　モニタ
B　　　　001B1,002B1,003B1,003B1　　　　　　　マウス
B　　　　001B2,002B2,003B2　　　　　　　　　　　キーボード

以下のコードを標準モジュールに貼り付け、実行します。

Sub test()
Dim i As Long
Dim j As Long
Dim x As Long
Dim y As Long
Dim z As Boolean
Dim wk As Workbook

Set wk = ThisWorkbook
i = wk.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row '最終行
j = wk.Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row '最終行

For x = 1 To i
　　z = False
　　For y = 1 To j
　　　　If wk.Sheets("sheet1").Cells(x, 1).Value = wk.Sheets("sheet2").Cells(y, 1).Value Then
　　　　　　If funcStr(wk.Sheets("sheet1").Cells(x, 2), wk.Sheets("sheet2").Cells(y, 2)) = True Then
　　　　　　　　wk.Sheets("sheet1").Cells(x, 3).Value = wk.Sheets("sheet2").Cells(y, 3).Value
　　　　　　　　z = True
　　　　　　　　Exit For
　　　　　　End If
　　　　End If
　　Next y
　　If z = False Then
　　　　wk.Sheets("sheet1").Cells(x, 3).Value = "該当無し"
　　End If
Next x
End Sub

Function funcStr(ByVal keyStr As String, ByVal myStr As String) As Boolean
　　Dim i As Long
　　Dim j As Long
　　Dim strArray As Variant

　　strArray = Split(myStr, ",")
　　For i = 0 To UBound(strArray)
　　　　If strArray(i) = keyStr Then
　　　　　　funcStr = True
　　　　　　Exit For
　　　　End If
　　Next i
End Function

結果は、

[sheet2]
A列　　　B列　　　　　C列
A　　　　A1003　　　　パソコン
B　　　　002B2　　　　キーボード
A　　　　A1001　　　　パソコン
A　　　　A1005　　　　該当無し
D　　　　005D2　　　　該当無し

勘違いしていなければ、ですが。