Option Explicit
Public Sub 項目組み合わせ検査()
Dim dict As Object '連想配列 キー:項目名+マシン名 値:件数
Dim ws1 As Worksheet 'シート1
Dim ws2 As Worksheet 'シート2
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のキー
Dim err_count As Long 'エラー件数
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
'組み合わせチェック
err_count = 0
For i = 0 To UBound(cols)
Call check_comb(ws2, dict, cols(i), err_count)
Next
MsgBox ("処理完了" & vbLf & "エラー件数=" & err_count)
End Sub
'組み合わせチェック
Private Sub check_comb(ws2 As Worksheet, dict As Object, ByVal col As Long, ByRef err_count)
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)
'エラー件数に1加算
err_count = err_count + 1
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
Dim temp As String
warr = Split("", vbLf)
If UBound(arr) < 0 Then Exit Sub
For i = 0 To UBound(arr)
temp = Trim(arr(i))
If temp <> "" Then
j = j + 1
ReDim Preserve warr(j)
warr(j) = temp
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