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

327 hits

【77100】階層構造のステータスの設定に関して imori 15/5/21(木) 15:50 質問[未読]
【77101】Re:階層構造のステータスの設定に関して β 15/5/21(木) 18:58 発言[未読]
【77108】Re:階層構造のステータスの設定に関して imori 15/5/22(金) 10:33 回答[未読]
【77113】Re:階層構造のステータスの設定に関して β 15/5/22(金) 17:44 発言[未読]
【77142】Re:階層構造のステータスの設定に関して imori 15/5/23(土) 22:12 お礼[未読]
【77102】Re:階層構造のステータスの設定に関して β 15/5/21(木) 19:26 発言[未読]
【77104】Re:階層構造のステータスの設定に関して β 15/5/21(木) 22:50 発言[未読]
【77105】Re:階層構造のステータスの設定に関して β 15/5/22(金) 6:55 発言[未読]
【77106】Re:階層構造のステータスの設定に関して β 15/5/22(金) 8:38 発言[未読]
【77109】Re:階層構造のステータスの設定に関して ウッシ 15/5/22(金) 12:03 回答[未読]
【77143】Re:階層構造のステータスの設定に関して imori 15/5/23(土) 23:28 お礼[未読]

5232 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free