3つのセルに当てはまる項目が一致したら、指定の単語を入れたい。

Question

3つのセルに当てはまる項目があれば、結果を表示させたい。

A2-C8に入力されている内容が検索対象の表です。
一致表のE2-G7が検索表と一致したら、H欄の表示項目をA12に表示させていきたいです。
検索表の項目が一致表にない事もあるので、その場合は色塗りができれば分かりやすいので助かります。

ifとcountifを考えたのですが、全く分かりませんでした。
一致表は、表示項目を追加していくので範囲が広いものがいいです。
お力添えを願います。

可能であれば、vbaでコードを作っていただけると助かります。
宜しくお願いします。

追記です。
ちなみに、A12に=VLOOKUP(A3&B3&C3,$E$3:$H$7,4)を入れたのですが、A12にトイレドア補修、A13洗面所水栓交換、A14襖補修、A15襖補修になりました。

Comments

[退会済みユーザー]

ご自分で「どう実装したのか」と「どううまくいかないのか」を書かないと、丸投げ指摘されますよ。

[1T2R3M4]

>vbaでコードを作っていただけると助かります。
作業依頼ですか。

Answer 1

暇だったので作ってみました。これを全て貼り付けて実行下さい。
表の拡張にも対応しております。

お仕事のなかでExcelを触る機会が多くあるなら、これを機に色々VBAについて調べてみては。
プログラミング初心者にはおすすめな言語だと思います。

※本サイトでは作業の丸投げはNGですので、次回から気をつけて下さいね。

'// 「一致表」の最後の列は必ず「表示項目」となるようにしてください



Sub main()
    Dim sh As Worksheet
        Set sh = ThisWorkbook.ActiveSheet
    

'★ここだけ変更してね===============================================================================
    Dim 検索表 As Range
        Set 検索表 = sh.Range("A3:C8")  '←タイトルを除いた表の範囲に応じて変更下さい
    
    Dim 一致表 As Range
        Set 一致表 = sh.Range("E3:H7") '←タイトルを除いた表の範囲に応じて変更下さい
        
    Dim 結果入力開始セル As Range
        Set 結果入力開始セル = sh.Range("A12")
    
    
'==================================================================================================



    '// 検索表リストの作成
    Dim Searchlist As Object
    Set Searchlist = CreateKeyList(検索表)
    
    '//一致表リストの作成
    Dim PrintList As Object
    Set PrintList = CreateKeyList(一致表)
    
    
    '// 結果表リストの作成
    Dim ResultList As Object
    Set ResultList = MergeList(Searchlist, PrintList)
    
    '// 検索開始
    Dim buf As Variant
    Dim endrow As Long
    endrow = sh.Cells(Rows.Count, 結果入力開始セル.Column).End(xlDown).row
    sh.Range(sh.Cells(結果入力開始セル.row, 結果入力開始セル.Column), sh.Cells(endrow, 結果入力開始セル.Column)).Clear
    
    '// 検索結果を排出
    Dim cnt As Long
    For Each buf In ResultList
        sh.Cells(結果入力開始セル.row + cnt, 結果入力開始セル.Column) = buf
        If buf = "入力する" Then: sh.Cells(結果入力開始セル.row + cnt, 結果入力開始セル.Column).Interior.Color = 65535
        
        cnt = cnt + 1
    Next
    

End Sub


'// Rangeを引数にして、行ごとにList.Addして返す
'   "トイレ|ドア|補修$トイレドア補修"といった形。

Private Function CreateKeyList(arg_rng As Range) As Object

    Dim lst As Object
        Set lst = CreateObject("System.Collections.ArrayList")
    Dim rowData As Variant
    Dim colData As Variant
   
    Dim keyValue As String
    Dim printValue As String
        For Each rowData In arg_rng.Rows
            keyValue = ""
            For Each colData In rowData.Columns
                If rowData.Columns.Count = colData.Column - rowData.Columns.Count Then
                    printValue = colData.Value
                Else
                    keyValue = keyValue & "|" & colData.Value
                End If
            Next
            lst.Add (keyValue & "$" & printValue)
        Next
    
    Set CreateKeyList = lst

End Function


Private Function MergeList(argSList As Object, argPList As Object) As Object

    Dim buf As Variant
    Dim F As Variant
    Dim index As Long
    
    Dim lst As Object
        Set lst = CreateObject("System.Collections.ArrayList")


        For Each buf In argSList
            index = IndexOf(argPList, buf)
            If index < 999999 Then
                F = Split(argPList.Item(IndexOf(argPList, buf)), "$")
                lst.Add (F(UBound(F)))
            Else
                lst.Add ("入力する")
                
            End If
            
        Next

    Set MergeList = lst
End Function

Public Function IndexOf(TargetList, element) As Variant
    Dim x
    Dim cnt As Long
    cnt = 0
    Dim flg As Boolean
    flg = False
    
    
    For Each x In TargetList
        If InStr(x, element) > 0 Then
            flg = True
            Exit For
        End If
        cnt = cnt + 1
    Next
    
    If flg Then
        IndexOf = cnt
    Else
        IndexOf = 999999
    End If
    
End Function

Answer 2

VBAを使わずExcelの式でアプローチするのも一手です。

'I3セルに以下の式を入れる。
=TEXTJOIN(",",TRUE,E3:G3)
'その後セルコピーしてI4以降に貼りつける。

'A12セルに以下の式を入れる。
=IFERROR(INDEX(H:H,MATCH(TEXTJOIN(",",TRUE,A3:C3),I:I,FALSE)),"入力する")
'その後セルコピーしてA13以降に貼りつける。

Comments

[sh444]

Excelが2010なので、TEXTJOINが使えないため、CONCATENATEを用いたのですが結果は入力するのみの表示になりました；

[jinoji]

それぞれ、以下に置き換えれば大丈夫だと思います。
=CONCAT(E3:G3)
=IFERROR(INDEX(H:H,MATCH(CONCAT(A3:C3),I:I,FALSE)),"入力する")

Answer 3

私ならDictionaryを使うと思います。
一致表を行ごとに読んで辞書にする（Keyは内容&項目&対応をつなげる、Itemは表示項目）
検索表を行ごとに読んで、同じようにKeyを作り、そのKEYで辞書から探し、
見つかったらそれを書く、見つからなければその旨書く

---

Sub sample()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    Dim dic As Scripting.Dictionary
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim 一致表 As Range
    Set 一致表 = ws.Range("E1").CurrentRegion
    With 一致表
        Dim i, k, v
        For i = 3 To .Rows.Count
            k = TabJoin(.Cells(i, 1).Resize(, .Columns.Count - 1).Value)
            v = .Cells(i, .Columns.Count).Value
            dic.Add k, v
        Next
    End With
    
    Dim 検索表 As Range
    Set 検索表 = ws.Range("A1").CurrentRegion
    With 検索表
        Dim j, s, outCell As Range
        For j = 3 To .Rows.Count
            Set outCell = ws.Cells(.Rows.Count + j, 1)
            
            s = TabJoin(.Rows(j).Value)
            
            If dic.Exists(s) Then
                outCell.Value = dic(s)
            Else
                outCell.Value = "入力する"
                outCell.Interior.Color = vbYellow
            End If
        Next
        ws.Cells(.Rows.Count + 2, 1).Value = "結果"
    End With
End Sub

Function TabJoin(r)
    With WorksheetFunction
'        TabJoin = .TextJoin(vbTab, True, r)
        TabJoin = Join(.Transpose(.Transpose(r)), vbTab)
    End With
End Function

Answer 4

For文でA列を検索してA列の文字を取得
次はB列、その次はC列
3つの文字列をくっつけて表示