VBAで1つのvlookupで複数の結果を取得する方法（vlookup値）

Question

3枚あり、シート1には「Register Codes」という列があり、固有コードを抽出しました。次の列に表示されます。下の画像をご確認ください。これらのユニークなコード、サブコードに基づいて

は、シート2に割り当てられている以下の画像をご確認下さい。

今、私はここにしようとしていると、シート3に、私はすべてのが「ユニークに基づいてのSheet2に割り当てられている関連「サブコード」で「コードを登録する」必要があるということですID "はSheet1で指定されています。下記の画像から期待される出力を確認してください。

私は式の様々な組み合わせを使用しているが、適切な解決策を得ることができませんでした。私がこの分野で勉強を始めたばかりのときに、VBAでそれを行う最良の方法は何ですか。

Answer 1

いくつかの条件のもとでは、次のコードは必要な処理を行います。標準コードモジュール（デフォルトでは "Module1"ですが、必要に応じて名前を付けることができます）にデータを格納しているワークブックにインストールします。

Option Explicit 

Enum Nws          ' Worksheet navigation 
    NwsFirstDataRow = 2       ' presumed the same for all worksheets 
    NwsCode = 1         ' 1 = column A (change as required) 
    NwsSubCode         ' No value means previous + 1 
    NwsNumer 
End Enum 

Sub NumerList() 
    ' 05 Apr 2017 

    Dim Wb As Workbook       ' all sheets are in the same workbook 
    Dim WsCodes As Worksheet     ' Register codes 
    Dim WsNum As Worksheet      ' Sub-code values 
    Dim WsOut As Worksheet      ' Output worksheet 
    Dim RegName As String, RegCode As String 
    Dim Sp() As String 
    Dim Rs As Long        ' Source row in WsNum 
    Dim Rt As Long        ' Target row in WsOut 
    Dim R As Long, Rl As Long     ' rows/Last row in WsCodes 

    Set Wb = ActiveWorkbook      ' Make sure it is active! 
    Set WsCodes = Wb.Worksheets("Reg Codes") ' Change name to your liking 
    Set WsNum = Wb.Worksheets("Code Values") ' Change name to your liking 

    On Error Resume Next 
    Set WsOut = Wb.Worksheets("Output")   ' Change name to your liking 
    If Err Then 
     Set WsOut = Wb.Worksheets.Add(After:=WsNum) 
     WsOut.Name = "Output"     ' create the worksheet if it doesn't exist 
    End If 
    On Error GoTo 0 

    Rt = NwsFirstDataRow 
    With WsCodes 
     Rl = .Cells(.Rows.Count, NwsCode).End(xlUp).Row 
     For R = NwsFirstDataRow To Rl 
      RegName = .Cells(R, NwsCode).Value 
      Sp = Split(RegName, "-") 
      If UBound(Sp) > 1 Then    ' must find at least 2 dashes 
       RegCode = Trim(Sp(1)) 
      Else 
       RegCode = "" 
      End If 

      If Len(RegCode) Then 
       On Error Resume Next 
       Rs = WorksheetFunction.Match(RegCode, WsNum.Columns(NwsCode), 0) 
       If Err Then Rs = 0 
       On Error GoTo 0 

       If Rs Then 
        Do 
         WsOut.Cells(Rt, NwsCode).Value = RegName 
         WsOut.Cells(Rt, NwsSubCode).Value = WsNum.Cells(Rs, NwsSubCode).Value 
         WsOut.Cells(Rt, NwsNumer).Value = WsNum.Cells(Rs, NwsNumer).Value 
         Rt = Rt + 1 
         Rs = Rs + 1 
        Loop While WsNum.Cells(Rs, NwsCode).Value = RegCode 
       Else 
        RegCode = "" 
       End If 
      End If 

      If Len(RegCode) = 0 Then 
       WsOut.Cells(Rt, NwsCode).Value = RegName 
       WsOut.Cells(Rt, NwsSubCode).Value = "No sub-code found" 
       Rt = Rt + 1 
      End If 
     Next R 
    End With 
End Sub 

そしてここに条件があります。

1. 3枚はすべて同じブックになければなりません。別のワークブックにそれらを持っている場合は、複数のワークブックを処理するためにコードを適合させる必要があります。
2. データのある2つのワークシートが存在する必要があります。それらはコードの規定に従って命名されなければならず、コードはそれらの名前と一致するように修正されなければならない。出力ワークシートも同じですが、存在しない場合はそのシートによって作成されます。コード内の名前を変更することができます。
3. コードの先頭の列挙は、3つのシートすべてが行1（キャプション）のデータと列A、BおよびCのデータと全く同じにフォーマットされていることを前提としています。変更は難しくありませんが、異なる入力または出力。既存のコードの列は、列挙型の列に他の値を代入して変更できますが、コードはすべてのシートで同じ配置を必要とします。
4. コードシートの抽出コードは使用されません。コードは独自の抽出を行います。コードを抽出できない場合、またはサブコードリストにコードが見つからない場合は、出力リストにエラーが表示されます。
5. Numerシートのサブコードは、投稿した写真のように並べ替える必要があります。コードは、最初の "画像"を探し、コードが列Aの "画像"である間に次の行にあるサブコードを見つけるでしょう。休憩の後に続く "画像"のそれ以降の出現を見つけることはありません。
6. コードに色付けはありません。それを追加することは難しくありませんが、最初の20コードに20色を加えて同じシーケンスを繰り返すなど、いくつかのルールを指定する必要があります。
7. 各セルが既に個別に名前が付けられているため、他のセルの書式設定を追加することもできます。より多くのプロパティを簡単に追加できます。