fork download
  1. Option Explicit
  2.  
  3. Public Sub 項目組み合わせ検査()
  4. Dim dict As Object '連想配列 キー:項目名+マシン名 値:件数
  5. Dim ws1 As Worksheet 'シート1
  6. Dim ws2 As Worksheet 'シート2
  7. Dim lastrow As Long '項目名の最終行
  8. Dim lastrowm As Long 'マシン名の最終行
  9. Dim row1 As Long '行番号
  10. Dim item As String '項目名
  11. Dim machines() As String 'マシン名(配列)
  12. Dim org_names() As String '本来のマシン名(配列)
  13. Dim machine As String 'マシン名
  14. Dim cols As Variant '列番号の配列
  15. Dim i As Long
  16. Dim key As String 'dictのキー
  17. Dim err_count As Long 'エラー件数
  18. cols = Array(1, 4, 7)
  19. Set dict = CreateObject("Scripting.Dictionary") ' 連想配列の定義
  20. Set ws1 = Worksheets("シート1")
  21. Set ws2 = Worksheets("シート2")
  22. lastrow = ws1.Cells(Rows.Count, "A").End(xlUp).Row 'A列最終行取得
  23. lastrowm = ws1.Cells(Rows.Count, "D").End(xlUp).Row 'D列最終行取得
  24. '大きいほうを最終行として採用する
  25. If lastrowm > lastrow Then lastrow = lastrowm
  26. '3~最終行まで繰り返す
  27. For row1 = 3 To lastrow
  28. '項目名取得
  29. item = getItem(ws1.Cells(row1, "A").Value)
  30. 'マシン名取得
  31. machines() = getMachine(ws1.Cells(row1, "D").Value, org_names)
  32. '共に空白なら処理しない
  33. If item = "" And UBound(machines) < 0 Then GoTo NEXT99
  34. 'どちらかが空白なら処理中止
  35. If item = "" Then Call error_proc(ws1.Cells(row1, "A"), "項目名未設定")
  36. If UBound(machines) < 0 Then Call error_proc(ws1.Cells(row1, "D"), "マシン名未設定")
  37. 'マシンの数分、連想配列に登録
  38. For i = 0 To UBound(machines)
  39. 'キーを作成し登録する
  40. key = item & "|" & machines(i)
  41. If dict.exists(key) = False Then
  42. dict(key) = 1
  43. Else
  44. dict(key) = dict(key) + 1
  45. End If
  46. Next
  47. NEXT99:
  48. Next
  49. '組み合わせチェック
  50. err_count = 0
  51. For i = 0 To UBound(cols)
  52. Call check_comb(ws2, dict, cols(i), err_count)
  53. Next
  54. MsgBox ("処理完了" & vbLf & "エラー件数=" & err_count)
  55. End Sub
  56. '組み合わせチェック
  57. Private Sub check_comb(ws2 As Worksheet, dict As Object, ByVal col As Long, ByRef err_count)
  58. Dim row2 As Long '行番号
  59. Dim lastrow As Long '項目名の最終行)
  60. Dim lastrowm As Long 'マシン名の最終行
  61. Dim item As String '項目名
  62. Dim machines() As String 'マシン名(配列)
  63. Dim org_names() As String '本来のマシン名(配列)
  64. Dim key As String 'dictのキー
  65. Dim i As Long
  66. lastrow = ws2.Cells(Rows.Count, col).End(xlUp).Row
  67. lastrowm = ws2.Cells(Rows.Count, col + 1).End(xlUp).Row
  68. If lastrowm > lastrow Then lastrow = lastrowm
  69. For row2 = 3 To lastrow
  70. '項目名取得
  71. item = getItem(ws2.Cells(row2, col).Value)
  72. 'マシン名取得
  73. machines = getMachine(ws2.Cells(row2, col + 1).Value, org_names)
  74. '見出しの場合は、スキップする
  75. If UBound(machines) = 0 Then
  76. If item = "項目名" And machines(0) = "実施マシン" Then GoTo NEXT99
  77. End If
  78. 'エラー情報のクリア
  79. ws2.Cells(row2, col).Interior.Pattern = xlNone
  80. ws2.Cells(row2, col + 1).Interior.Pattern = xlNone
  81. ws2.Cells(row2, col + 2).Value = ""
  82. '共に空白なら処理しない
  83. If item = "" And UBound(machines) < 0 Then GoTo NEXT99
  84. 'どちらかが空白なら処理中止
  85. If item = "" Then Call error_proc(ws2.Cells(row2, col), "項目名未設定")
  86. If UBound(machines) < 0 Then Call error_proc(ws2.Cells(row2, col + 1), "マシン名未設定")
  87. '項目の組み合わせチェック
  88. For i = 0 To UBound(machines)
  89. 'キーを作成、連想配列に未登録なら、エラー処理を行う
  90. key = item & "|" & machines(i)
  91. If dict.exists(key) = False Then
  92. '背景色を黄色にする
  93. ws2.Cells(row2, col).Interior.Color = vbYellow
  94. ws2.Cells(row2, col + 1).Interior.Color = vbYellow
  95. '未登録のマシン名を出力する
  96. If ws2.Cells(row2, col + 2).Value <> "" Then
  97. ws2.Cells(row2, col + 2).Value = ws2.Cells(row2, col + 2).Value & vbLf
  98. End If
  99. ws2.Cells(row2, col + 2).Value = ws2.Cells(row2, col + 2).Value & org_names(i)
  100. 'エラー件数に1加算
  101. err_count = err_count + 1
  102. End If
  103. Next
  104. NEXT99:
  105. Next
  106. End Sub
  107. '項目名取得
  108. Private Function getItem(ByVal val As String) As String
  109. Dim temp As String
  110. '両端の空白を削除する
  111. temp = Trim(val)
  112. '全角の大文字に変換する
  113. getItem = StrConv(temp, vbUpperCase + vbWide)
  114. End Function
  115. 'マシン名取得
  116. Private Function getMachine(ByVal val As String, org_names() As String) As String()
  117. Dim temp As String
  118. Dim elm() As String
  119. Dim i As Long
  120. '両端の空白を削除する
  121. temp = Trim(val)
  122. '改行で分割する(全角、大文字に変換しない)
  123. org_names = Split(temp, vbLf)
  124. '空の要素を削除
  125. Call seikei(org_names)
  126. '全角の大文字に変換する
  127. temp = StrConv(temp, vbUpperCase + vbWide)
  128. '改行で分割する
  129. getMachine = Split(temp, vbLf)
  130. '空の要素を削除
  131. Call seikei(getMachine)
  132. End Function
  133. 'マシン名の配列から空の要素を削除
  134. Private Sub seikei(arr() As String)
  135. Dim i As Long
  136. Dim j As Long: j = -1
  137. Dim warr() As String
  138. Dim temp As String
  139. warr = Split("", vbLf)
  140. If UBound(arr) < 0 Then Exit Sub
  141. For i = 0 To UBound(arr)
  142. temp = Trim(arr(i))
  143. If temp <> "" Then
  144. j = j + 1
  145. ReDim Preserve warr(j)
  146. warr(j) = temp
  147. End If
  148. Next
  149. arr = warr
  150. End Sub
  151. 'エラー処理
  152. Private Sub error_proc(rng As Range, msg As String)
  153. '該当シートをアクティブにして、該当セルを選択する
  154. rng.Parent.Activate
  155. rng.Select
  156. 'エラーメッセージ表示
  157. MsgBox (rng.Parent.Name & vbLf & msg)
  158. End
  159. End Sub
  160.  
  161.  
  162.  
Not running #stdin #stdout 0s 0KB
stdin
Standard input is empty
stdout
Standard output is empty