Option Explicit
 
Public Sub 項目組み合わせ検査()
    Dim dict As Object          '連想配列　キー：項目名＋マシン名　値：件数
    Dim ws1 As Worksheet        'シート１
    Dim ws2 As Worksheet        'シート２
    Dim lastrow As Long         '項目名の最終行
    Dim lastrowm As Long        'マシン名の最終行
    Dim row1 As Long            '行番号
    Dim item As String          '項目名
    Dim machines() As String    'マシン名（配列）
    Dim org_names() As String   '本来のマシン名（配列）
    Dim machine As String       'マシン名
    Dim cols As Variant         '列番号の配列
    Dim i As Long
    Dim key As String           'dictのキー
    cols = Array(1, 4, 7)
    Set dict = CreateObject("Scripting.Dictionary") ' 連想配列の定義
    Set ws1 = Worksheets("シート1")
    Set ws2 = Worksheets("シート2")
    lastrow = ws1.Cells(Rows.Count, "A").End(xlUp).Row      'A列最終行取得
    lastrowm = ws1.Cells(Rows.Count, "D").End(xlUp).Row     'D列最終行取得
    '大きいほうを最終行として採用する
    If lastrowm > lastrow Then lastrow = lastrowm
    '3～最終行まで繰り返す
    For row1 = 3 To lastrow
        '項目名取得
        item = getItem(ws1.Cells(row1, "A").Value)
        'マシン名取得
        machines() = getMachine(ws1.Cells(row1, "D").Value, org_names)
        '共に空白なら処理しない
        If item = "" And UBound(machines) < 0 Then GoTo NEXT99
        'どちらかが空白なら処理中止
        If item = "" Then Call error_proc(ws1.Cells(row1, "A"), "項目名未設定")
        If UBound(machines) < 0 Then Call error_proc(ws1.Cells(row1, "D"), "マシン名未設定")
        'マシンの数分、連想配列に登録
        For i = 0 To UBound(machines)
            'キーを作成し登録する
            key = item & "|" & machines(i)
            If dict.exists(key) = False Then
                dict(key) = 1
            Else
                dict(key) = dict(key) + 1
            End If
        Next
NEXT99:
    Next
    '組み合わせチェック
    For i = 0 To UBound(cols)
        Call check_comb(ws2, dict, cols(i))
    Next
    MsgBox ("完了")
End Sub
'組み合わせチェック
Private Sub check_comb(ws2 As Worksheet, dict As Object, ByVal col As Long)
    Dim row2 As Long                '行番号
    Dim lastrow As Long             '項目名の最終行）
    Dim lastrowm As Long            'マシン名の最終行
    Dim item As String              '項目名
    Dim machines() As String        'マシン名（配列）
    Dim org_names() As String       '本来のマシン名（配列）
    Dim key As String               'dictのキー
    Dim i As Long
    lastrow = ws2.Cells(Rows.Count, col).End(xlUp).Row
    lastrowm = ws2.Cells(Rows.Count, col + 1).End(xlUp).Row
    If lastrowm > lastrow Then lastrow = lastrowm
    For row2 = 3 To lastrow
        '項目名取得
        item = getItem(ws2.Cells(row2, col).Value)
        'マシン名取得
        machines = getMachine(ws2.Cells(row2, col + 1).Value, org_names)
        '見出しの場合は、スキップする
        If UBound(machines) = 0 Then
            If item = "項目名" And machines(0) = "実施マシン" Then GoTo NEXT99
        End If
        'エラー情報のクリア
        ws2.Cells(row2, col).Interior.Pattern = xlNone
        ws2.Cells(row2, col + 1).Interior.Pattern = xlNone
        ws2.Cells(row2, col + 2).Value = ""
        '共に空白なら処理しない
        If item = "" And UBound(machines) < 0 Then GoTo NEXT99
        'どちらかが空白なら処理中止
        If item = "" Then Call error_proc(ws2.Cells(row2, col), "項目名未設定")
        If UBound(machines) < 0 Then Call error_proc(ws2.Cells(row2, col + 1), "マシン名未設定")
        '項目の組み合わせチェック
        For i = 0 To UBound(machines)
            'キーを作成、連想配列に未登録なら、エラー処理を行う
            key = item & "|" & machines(i)
            If dict.exists(key) = False Then
                '背景色を黄色にする
                ws2.Cells(row2, col).Interior.Color = vbYellow
                ws2.Cells(row2, col + 1).Interior.Color = vbYellow
                'シート１に未登録のマシンを出力する
                If ws2.Cells(row2, col + 2).Value <> "" Then
                    ws2.Cells(row2, col + 2).Value = ws2.Cells(row2, col + 2).Value & vbLf
                End If
                ws2.Cells(row2, col + 2).Value = ws2.Cells(row2, col + 2).Value & org_names(i)
            End If
        Next
NEXT99:
    Next
End Sub
'項目名取得
Private Function getItem(ByVal val As String) As String
    Dim temp As String
    '両端の空白を削除する
    temp = Trim(val)
    '全角の大文字に変換する
    getItem = StrConv(temp, vbUpperCase + vbWide)
End Function
'マシン名取得
Private Function getMachine(ByVal val As String, org_names() As String) As String()
    Dim temp As String
    Dim elm() As String
    Dim i As Long
    '両端の空白を削除する
    temp = Trim(val)
    '改行で分割する（全角、大文字に変換しない）
    org_names = Split(temp, vbLf)
    '空の配列を削除
    Call seikei(org_names)
    '全角の大文字に変換する
    temp = StrConv(temp, vbUpperCase + vbWide)
    '改行で分割する
    getMachine = Split(temp, vbLf)
    '空の配列を削除
    Call seikei(getMachine)
End Function
'マシン名の配列から空の配列を削除
Private Sub seikei(arr() As String)
    Dim i As Long
    Dim j As Long: j = -1
    Dim warr() As String
    warr = Split("", vbLf)
    If UBound(arr) < 0 Then Exit Sub
    For i = 0 To UBound(arr)
        If arr(i) <> "" Then
            j = j + 1
            ReDim Preserve warr(j)
            warr(j) = arr(i)
        End If
    Next
    arr = warr
End Sub
'エラー処理
Private Sub error_proc(rng As Range, msg As String)
    '該当シートをアクティブにして、該当セルを選択する
    rng.Parent.Activate
    rng.Select
    'エラーメッセージ表示
    MsgBox (rng.Parent.Name & vbLf & msg)
    End
End Sub
 
 
 

T3B0aW9uIEV4cGxpY2l0CgpQdWJsaWMgU3ViIOmgheebrue1hOOBv+WQiOOCj+OBm+aknOafuygpCiAgICBEaW0gZGljdCBBcyBPYmplY3QgICAgICAgICAgJ+mAo+aDs+mFjeWIl+OAgOOCreODvO+8mumgheebruWQje+8i+ODnuOCt+ODs+WQjeOAgOWApO+8muS7tuaVsAogICAgRGltIHdzMSBBcyBXb3Jrc2hlZXQgICAgICAgICfjgrfjg7zjg4jvvJEKICAgIERpbSB3czIgQXMgV29ya3NoZWV0ICAgICAgICAn44K344O844OI77ySCiAgICBEaW0gbGFzdHJvdyBBcyBMb25nICAgICAgICAgJ+mgheebruWQjeOBruacgOe1guihjAogICAgRGltIGxhc3Ryb3dtIEFzIExvbmcgICAgICAgICfjg57jgrfjg7PlkI3jga7mnIDntYLooYwKICAgIERpbSByb3cxIEFzIExvbmcgICAgICAgICAgICAn6KGM55Wq5Y+3CiAgICBEaW0gaXRlbSBBcyBTdHJpbmcgICAgICAgICAgJ+mgheebruWQjQogICAgRGltIG1hY2hpbmVzKCkgQXMgU3RyaW5nICAgICfjg57jgrfjg7PlkI3vvIjphY3liJfvvIkKICAgIERpbSBvcmdfbmFtZXMoKSBBcyBTdHJpbmcgICAn5pys5p2l44Gu44Oe44K344Oz5ZCN77yI6YWN5YiX77yJCiAgICBEaW0gbWFjaGluZSBBcyBTdHJpbmcgICAgICAgJ+ODnuOCt+ODs+WQjQogICAgRGltIGNvbHMgQXMgVmFyaWFudCAgICAgICAgICfliJfnlarlj7fjga7phY3liJcKICAgIERpbSBpIEFzIExvbmcKICAgIERpbSBrZXkgQXMgU3RyaW5nICAgICAgICAgICAnZGljdOOBruOCreODvAogICAgY29scyA9IEFycmF5KDEsIDQsIDcpCiAgICBTZXQgZGljdCA9IENyZWF0ZU9iamVjdCgiU2NyaXB0aW5nLkRpY3Rpb25hcnkiKSAnIOmAo+aDs+mFjeWIl+OBruWumue+qQogICAgU2V0IHdzMSA9IFdvcmtzaGVldHMoIuOCt+ODvOODiDEiKQogICAgU2V0IHdzMiA9IFdvcmtzaGVldHMoIuOCt+ODvOODiDIiKQogICAgbGFzdHJvdyA9IHdzMS5DZWxscyhSb3dzLkNvdW50LCAiQSIpLkVuZCh4bFVwKS5Sb3cgICAgICAnQeWIl+acgOe1guihjOWPluW+lwogICAgbGFzdHJvd20gPSB3czEuQ2VsbHMoUm93cy5Db3VudCwgIkQiKS5FbmQoeGxVcCkuUm93ICAgICAnROWIl+acgOe1guihjOWPluW+lwogICAgJ+Wkp+OBjeOBhOOBu+OBhuOCkuacgOe1guihjOOBqOOBl+OBpuaOoeeUqOOBmeOCiwogICAgSWYgbGFzdHJvd20gPiBsYXN0cm93IFRoZW4gbGFzdHJvdyA9IGxhc3Ryb3dtCiAgICAnM++9nuacgOe1guihjOOBvuOBp+e5sOOCiui/lOOBmQogICAgRm9yIHJvdzEgPSAzIFRvIGxhc3Ryb3cKICAgICAgICAn6aCF55uu5ZCN5Y+W5b6XCiAgICAgICAgaXRlbSA9IGdldEl0ZW0od3MxLkNlbGxzKHJvdzEsICJBIikuVmFsdWUpCiAgICAgICAgJ+ODnuOCt+ODs+WQjeWPluW+lwogICAgICAgIG1hY2hpbmVzKCkgPSBnZXRNYWNoaW5lKHdzMS5DZWxscyhyb3cxLCAiRCIpLlZhbHVlLCBvcmdfbmFtZXMpCiAgICAgICAgJ+WFseOBq+epuueZveOBquOCieWHpueQhuOBl+OBquOBhAogICAgICAgIElmIGl0ZW0gPSAiIiBBbmQgVUJvdW5kKG1hY2hpbmVzKSA8IDAgVGhlbiBHb1RvIE5FWFQ5OQogICAgICAgICfjganjgaHjgonjgYvjgYznqbrnmb3jgarjgonlh6bnkIbkuK3mraIKICAgICAgICBJZiBpdGVtID0gIiIgVGhlbiBDYWxsIGVycm9yX3Byb2Mod3MxLkNlbGxzKHJvdzEsICJBIiksICLpoIXnm67lkI3mnKroqK3lrpoiKQogICAgICAgIElmIFVCb3VuZChtYWNoaW5lcykgPCAwIFRoZW4gQ2FsbCBlcnJvcl9wcm9jKHdzMS5DZWxscyhyb3cxLCAiRCIpLCAi44Oe44K344Oz5ZCN5pyq6Kit5a6aIikKICAgICAgICAn44Oe44K344Oz44Gu5pWw5YiG44CB6YCj5oOz6YWN5YiX44Gr55m76YyyCiAgICAgICAgRm9yIGkgPSAwIFRvIFVCb3VuZChtYWNoaW5lcykKICAgICAgICAgICAgJ+OCreODvOOCkuS9nOaIkOOBl+eZu+mMsuOBmeOCiwogICAgICAgICAgICBrZXkgPSBpdGVtICYgInwiICYgbWFjaGluZXMoaSkKICAgICAgICAgICAgSWYgZGljdC5leGlzdHMoa2V5KSA9IEZhbHNlIFRoZW4KICAgICAgICAgICAgICAgIGRpY3Qoa2V5KSA9IDEKICAgICAgICAgICAgRWxzZQogICAgICAgICAgICAgICAgZGljdChrZXkpID0gZGljdChrZXkpICsgMQogICAgICAgICAgICBFbmQgSWYKICAgICAgICBOZXh0Ck5FWFQ5OToKICAgIE5leHQKICAgICfntYTjgb/lkIjjgo/jgZvjg4Hjgqfjg4Pjgq8KICAgIEZvciBpID0gMCBUbyBVQm91bmQoY29scykKICAgICAgICBDYWxsIGNoZWNrX2NvbWIod3MyLCBkaWN0LCBjb2xzKGkpKQogICAgTmV4dAogICAgTXNnQm94ICgi5a6M5LqGIikKRW5kIFN1Ygon57WE44G/5ZCI44KP44Gb44OB44Kn44OD44KvClByaXZhdGUgU3ViIGNoZWNrX2NvbWIod3MyIEFzIFdvcmtzaGVldCwgZGljdCBBcyBPYmplY3QsIEJ5VmFsIGNvbCBBcyBMb25nKQogICAgRGltIHJvdzIgQXMgTG9uZyAgICAgICAgICAgICAgICAn6KGM55Wq5Y+3CiAgICBEaW0gbGFzdHJvdyBBcyBMb25nICAgICAgICAgICAgICfpoIXnm67lkI3jga7mnIDntYLooYzvvIkKICAgIERpbSBsYXN0cm93bSBBcyBMb25nICAgICAgICAgICAgJ+ODnuOCt+ODs+WQjeOBruacgOe1guihjAogICAgRGltIGl0ZW0gQXMgU3RyaW5nICAgICAgICAgICAgICAn6aCF55uu5ZCNCiAgICBEaW0gbWFjaGluZXMoKSBBcyBTdHJpbmcgICAgICAgICfjg57jgrfjg7PlkI3vvIjphY3liJfvvIkKICAgIERpbSBvcmdfbmFtZXMoKSBBcyBTdHJpbmcgICAgICAgJ+acrOadpeOBruODnuOCt+ODs+WQje+8iOmFjeWIl++8iQogICAgRGltIGtleSBBcyBTdHJpbmcgICAgICAgICAgICAgICAnZGljdOOBruOCreODvAogICAgRGltIGkgQXMgTG9uZwogICAgbGFzdHJvdyA9IHdzMi5DZWxscyhSb3dzLkNvdW50LCBjb2wpLkVuZCh4bFVwKS5Sb3cKICAgIGxhc3Ryb3dtID0gd3MyLkNlbGxzKFJvd3MuQ291bnQsIGNvbCArIDEpLkVuZCh4bFVwKS5Sb3cKICAgIElmIGxhc3Ryb3dtID4gbGFzdHJvdyBUaGVuIGxhc3Ryb3cgPSBsYXN0cm93bQogICAgRm9yIHJvdzIgPSAzIFRvIGxhc3Ryb3cKICAgICAgICAn6aCF55uu5ZCN5Y+W5b6XCiAgICAgICAgaXRlbSA9IGdldEl0ZW0od3MyLkNlbGxzKHJvdzIsIGNvbCkuVmFsdWUpCiAgICAgICAgJ+ODnuOCt+ODs+WQjeWPluW+lwogICAgICAgIG1hY2hpbmVzID0gZ2V0TWFjaGluZSh3czIuQ2VsbHMocm93MiwgY29sICsgMSkuVmFsdWUsIG9yZ19uYW1lcykKICAgICAgICAn6KaL5Ye644GX44Gu5aC05ZCI44Gv44CB44K544Kt44OD44OX44GZ44KLCiAgICAgICAgSWYgVUJvdW5kKG1hY2hpbmVzKSA9IDAgVGhlbgogICAgICAgICAgICBJZiBpdGVtID0gIumgheebruWQjSIgQW5kIG1hY2hpbmVzKDApID0gIuWun+aWveODnuOCt+ODsyIgVGhlbiBHb1RvIE5FWFQ5OQogICAgICAgIEVuZCBJZgogICAgICAgICfjgqjjg6njg7zmg4XloLHjga7jgq/jg6rjgqIKICAgICAgICB3czIuQ2VsbHMocm93MiwgY29sKS5JbnRlcmlvci5QYXR0ZXJuID0geGxOb25lCiAgICAgICAgd3MyLkNlbGxzKHJvdzIsIGNvbCArIDEpLkludGVyaW9yLlBhdHRlcm4gPSB4bE5vbmUKICAgICAgICB3czIuQ2VsbHMocm93MiwgY29sICsgMikuVmFsdWUgPSAiIgogICAgICAgICflhbHjgavnqbrnmb3jgarjgonlh6bnkIbjgZfjgarjgYQKICAgICAgICBJZiBpdGVtID0gIiIgQW5kIFVCb3VuZChtYWNoaW5lcykgPCAwIFRoZW4gR29UbyBORVhUOTkKICAgICAgICAn44Gp44Gh44KJ44GL44GM56m655m944Gq44KJ5Yem55CG5Lit5q2iCiAgICAgICAgSWYgaXRlbSA9ICIiIFRoZW4gQ2FsbCBlcnJvcl9wcm9jKHdzMi5DZWxscyhyb3cyLCBjb2wpLCAi6aCF55uu5ZCN5pyq6Kit5a6aIikKICAgICAgICBJZiBVQm91bmQobWFjaGluZXMpIDwgMCBUaGVuIENhbGwgZXJyb3JfcHJvYyh3czIuQ2VsbHMocm93MiwgY29sICsgMSksICLjg57jgrfjg7PlkI3mnKroqK3lrpoiKQogICAgICAgICfpoIXnm67jga7ntYTjgb/lkIjjgo/jgZvjg4Hjgqfjg4Pjgq8KICAgICAgICBGb3IgaSA9IDAgVG8gVUJvdW5kKG1hY2hpbmVzKQogICAgICAgICAgICAn44Kt44O844KS5L2c5oiQ44CB6YCj5oOz6YWN5YiX44Gr5pyq55m76Yyy44Gq44KJ44CB44Ko44Op44O85Yem55CG44KS6KGM44GGCiAgICAgICAgICAgIGtleSA9IGl0ZW0gJiAifCIgJiBtYWNoaW5lcyhpKQogICAgICAgICAgICBJZiBkaWN0LmV4aXN0cyhrZXkpID0gRmFsc2UgVGhlbgogICAgICAgICAgICAgICAgJ+iDjOaZr+iJsuOCkum7hOiJsuOBq+OBmeOCiwogICAgICAgICAgICAgICAgd3MyLkNlbGxzKHJvdzIsIGNvbCkuSW50ZXJpb3IuQ29sb3IgPSB2YlllbGxvdwogICAgICAgICAgICAgICAgd3MyLkNlbGxzKHJvdzIsIGNvbCArIDEpLkludGVyaW9yLkNvbG9yID0gdmJZZWxsb3cKICAgICAgICAgICAgICAgICfjgrfjg7zjg4jvvJHjgavmnKrnmbvpjLLjga7jg57jgrfjg7PjgpLlh7rlipvjgZnjgosKICAgICAgICAgICAgICAgIElmIHdzMi5DZWxscyhyb3cyLCBjb2wgKyAyKS5WYWx1ZSA8PiAiIiBUaGVuCiAgICAgICAgICAgICAgICAgICAgd3MyLkNlbGxzKHJvdzIsIGNvbCArIDIpLlZhbHVlID0gd3MyLkNlbGxzKHJvdzIsIGNvbCArIDIpLlZhbHVlICYgdmJMZgogICAgICAgICAgICAgICAgRW5kIElmCiAgICAgICAgICAgICAgICB3czIuQ2VsbHMocm93MiwgY29sICsgMikuVmFsdWUgPSB3czIuQ2VsbHMocm93MiwgY29sICsgMikuVmFsdWUgJiBvcmdfbmFtZXMoaSkKICAgICAgICAgICAgRW5kIElmCiAgICAgICAgTmV4dApORVhUOTk6CiAgICBOZXh0CkVuZCBTdWIKJ+mgheebruWQjeWPluW+lwpQcml2YXRlIEZ1bmN0aW9uIGdldEl0ZW0oQnlWYWwgdmFsIEFzIFN0cmluZykgQXMgU3RyaW5nCiAgICBEaW0gdGVtcCBBcyBTdHJpbmcKICAgICfkuKHnq6/jga7nqbrnmb3jgpLliYrpmaTjgZnjgosKICAgIHRlbXAgPSBUcmltKHZhbCkKICAgICflhajop5Ljga7lpKfmloflrZfjgavlpInmj5vjgZnjgosKICAgIGdldEl0ZW0gPSBTdHJDb252KHRlbXAsIHZiVXBwZXJDYXNlICsgdmJXaWRlKQpFbmQgRnVuY3Rpb24KJ+ODnuOCt+ODs+WQjeWPluW+lwpQcml2YXRlIEZ1bmN0aW9uIGdldE1hY2hpbmUoQnlWYWwgdmFsIEFzIFN0cmluZywgb3JnX25hbWVzKCkgQXMgU3RyaW5nKSBBcyBTdHJpbmcoKQogICAgRGltIHRlbXAgQXMgU3RyaW5nCiAgICBEaW0gZWxtKCkgQXMgU3RyaW5nCiAgICBEaW0gaSBBcyBMb25nCiAgICAn5Lih56uv44Gu56m655m944KS5YmK6Zmk44GZ44KLCiAgICB0ZW1wID0gVHJpbSh2YWwpCiAgICAn5pS56KGM44Gn5YiG5Ymy44GZ44KL77yI5YWo6KeS44CB5aSn5paH5a2X44Gr5aSJ5o+b44GX44Gq44GE77yJCiAgICBvcmdfbmFtZXMgPSBTcGxpdCh0ZW1wLCB2YkxmKQogICAgJ+epuuOBrumFjeWIl+OCkuWJiumZpAogICAgQ2FsbCBzZWlrZWkob3JnX25hbWVzKQogICAgJ+WFqOinkuOBruWkp+aWh+Wtl+OBq+WkieaPm+OBmeOCiwogICAgdGVtcCA9IFN0ckNvbnYodGVtcCwgdmJVcHBlckNhc2UgKyB2YldpZGUpCiAgICAn5pS56KGM44Gn5YiG5Ymy44GZ44KLCiAgICBnZXRNYWNoaW5lID0gU3BsaXQodGVtcCwgdmJMZikKICAgICfnqbrjga7phY3liJfjgpLliYrpmaQKICAgIENhbGwgc2Vpa2VpKGdldE1hY2hpbmUpCkVuZCBGdW5jdGlvbgon44Oe44K344Oz5ZCN44Gu6YWN5YiX44GL44KJ56m644Gu6YWN5YiX44KS5YmK6ZmkClByaXZhdGUgU3ViIHNlaWtlaShhcnIoKSBBcyBTdHJpbmcpCiAgICBEaW0gaSBBcyBMb25nCiAgICBEaW0gaiBBcyBMb25nOiBqID0gLTEKICAgIERpbSB3YXJyKCkgQXMgU3RyaW5nCiAgICB3YXJyID0gU3BsaXQoIiIsIHZiTGYpCiAgICBJZiBVQm91bmQoYXJyKSA8IDAgVGhlbiBFeGl0IFN1YgogICAgRm9yIGkgPSAwIFRvIFVCb3VuZChhcnIpCiAgICAgICAgSWYgYXJyKGkpIDw+ICIiIFRoZW4KICAgICAgICAgICAgaiA9IGogKyAxCiAgICAgICAgICAgIFJlRGltIFByZXNlcnZlIHdhcnIoaikKICAgICAgICAgICAgd2FycihqKSA9IGFycihpKQogICAgICAgIEVuZCBJZgogICAgTmV4dAogICAgYXJyID0gd2FycgpFbmQgU3ViCifjgqjjg6njg7zlh6bnkIYKUHJpdmF0ZSBTdWIgZXJyb3JfcHJvYyhybmcgQXMgUmFuZ2UsIG1zZyBBcyBTdHJpbmcpCiAgICAn6Kmy5b2T44K344O844OI44KS44Ki44Kv44OG44Kj44OW44Gr44GX44Gm44CB6Kmy5b2T44K744Or44KS6YG45oqe44GZ44KLCiAgICBybmcuUGFyZW50LkFjdGl2YXRlCiAgICBybmcuU2VsZWN0CiAgICAn44Ko44Op44O844Oh44OD44K744O844K46KGo56S6CiAgICBNc2dCb3ggKHJuZy5QYXJlbnQuTmFtZSAmIHZiTGYgJiBtc2cpCiAgICBFbmQKRW5kIFN1YgoKCg==