Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

5232 / 76732

←次へ　｜　前へ→


	【77113】Re:階層構造のステータスの設定に関して

β - 15/5/22(金) 17:44 -


	引用なし

	パスワード

▼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

328 hits

▼

【77100】階層構造のステータスの設定に関して imori 15/5/21(木) 15:50