Excel VBA質問箱 IV

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

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


5245 / 76732 ←次へ | 前へ→

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

引用なし
パスワード
   はじまして、imoriと申します。
現在以下のようなマクロを組んでいるのですが、
無限ループになってしまったり、分岐が上手くいかなかったりとで試行錯誤しており苦しんでおります。
どうかご教授ねがえませんでしょうか。

階層構造の末端部分のステータスによって、
一段階上のステータスが決まるマクロを書きたいです。
ステータスはOK、NG、保留があり、ステータス決定のルールは以下の通りです。
1.番号の下に階層が存在しない場合でステータスがブランクの場合は[保留]
2.番号の下に階層が存在しており、一つでもNGがあれば、上のステータスは[NG]
3.番号の下に階層が存在しており、NGがなく、一つでも保留があれば上のステータスは[保留]
4.番号の下に階層が存在しており、NG、保留がない場合は[OK]

以下のように並んでいる場合□の箇所のステータスを設定するマクロを作成したいです。
階層    番号    ステータス
1    000001    □(1)・・・2のステータスがNGのためNG
2    000002    □(2)・・・3のステータスにNGが存在するためNG
3    000003    OK
4    000004    OK
4    000005    OK
3    000006    □(3)・・・下の階層(4)にNGが存在するためNG
4    000007    NG
4    000008    □(4)・・・下に階層が続かないためステータスは[保留]
4    000009    OK
4    000010    NG
3    000011    □(5)・・・下の階層がOKのため[OK]
4    000012    OK
4    000013    OK
3    000014    OK


現在組んでいるマクロは以下の通りです。
以下の番号のステータスが一致しません。
000001
000002
他のやりかたを考えるべきと思い始めています。
ご教授願えますでしょうか。


Option Explicit

Sub Main()
Dim i, MaxRow As Long
MaxRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To MaxRow
  階層設定 (i)
Next i
MsgBox "完了しました"

End Sub

Sub 階層設定(i)
Dim r, m, l As Long
Dim sArray() As String
m = 0
r = 0
Do While Range("C" & i).Value = ""

  
  '行の次の行の階層レベルが同じもしくは次の行が小さい場合、その行は末端のためステータス「保留」
  If Range("A" & i).Value >= Range("A" & i + 1) Then
    Range("C" & i) = "保留"
  '行の次の行の階層が+1の場合は下に階層がある
  Else
    r = i + 1
    '次の行のステータスがブランクではない場合
    If Range("C" & r).Value <> "" Then
      '次の行のレベルと次の次の行のレベルが同一である限り配列に値格納
      Do
        ReDim Preserve sArray(m)
        sArray(m) = Range("C" & r).Value
        r = r + 1
        m = m + 1
      Loop While Range("A" & r) = Range("A" & r + 1)
      Range("C" & i) = ステータス設定(sArray())
      '配列の解放
      m = 0
      Erase sArray
    Else
      '****上と同じ処理が続いてしまう。
      If Range("A" & r).Value >= Range("A" & r + 1) Then
        '行の次の行の階層レベルが同じもしくは次の行が小さい場合、その行は末端のためステータス「保留」
        Range("C" & r) = "保留"
      Else
        階層設定 (i + 1)
        
      End If
    End If
  End If
Loop


End Sub

Function ステータス設定(sArray() As String) As String
Dim strResult, strTarget As String

strResult = Filter(sArray, "NG")
'NGが含まれている場合
If UBound(strResult) <> -1 Then
  strTarget = "NG"
Else
  'NGは含まれていないが、保留が含まれている場合
  strResult = Filter(sArray, "保留")
  If UBound(strResult) <> -1 Then
    strTarget = "保留"
  Else
    strTarget = "OK"
  End If
End If
ステータス設定 = strTarget
End Function


よろしくお願いします。
245 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 お礼[未読]

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