|
▼imori さん:
自信度、60%ぐらいになったかも。
クラスモジュール(Class1)を挿入してください。
(標準モジュール)
Option Explicit
Type status
hold As Boolean
ng As Boolean
End Type
Sub test3()
Dim clsPool As Collection
Dim cls As Class1
Dim w As Variant
Dim c As Range
Dim lvl As Long
Dim maxLvl As Long
Dim x As Long
Dim st As status
Dim i As Long
Set clsPool = New Collection
With Range("A2", Range("A" & Rows.Count).End(xlUp))
maxLvl = WorksheetFunction.Max(.Columns(1))
ReDim w(1 To maxLvl)
'階層構造の取り込み
For Each c In .Cells
lvl = c.Value
Set cls = New Class1
cls.init c.Offset(, 1).Value
clsPool.add cls
Set w(lvl) = cls
If lvl > 1 Then
Set cls = w(lvl - 1) '親
cls.add c.Row
End If
Next
'判定
For i = .Rows.Count + 1 To 2 Step -1
Set c = Cells(i, "A")
x = i - 1
If IsEmpty(c.Offset(, 2)) Then
Set cls = clsPool(x)
st = cls.GetStatus
If st.ng Then
c.Offset(, 2).Value = "NG"
ElseIf st.hold Then
c.Offset(, 2) = "保留"
Else
c.Offset(, 2).Value = "OK"
End If
End If
Next
End With
Erase w
Set cls = Nothing
Set clsPool = Nothing
End Sub
(クラスモジュール Class1)
Option Explicit
Dim pool As Collection
Dim myIndex As String
Sub init(idx As String)
Set pool = New Collection
myIndex = idx
End Sub
Sub add(dRow As Long)
pool.add dRow
End Sub
Function GetStatus() As status
Dim i As Long
If pool.Count = 0 Then
GetStatus.hold = True
Exit Function
End If
For i = 1 To pool.Count
Select Case Cells(pool(i), "C")
Case "NG": GetStatus.ng = True
Case "保留": GetStatus.hold = True
End Select
If GetStatus.ng Then Exit For
Next
End Function
Private Sub Class_Terminate()
Set pool = Nothing
End Sub
|
|