Excel VBA質問箱 IV

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

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


979 / 13644 ツリー ←次へ | 前へ→

【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 お礼[未読]

【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


よろしくお願いします。

【77101】Re:階層構造のステータスの設定に関して
発言  β  - 15/5/21(木) 18:58 -

引用なし
パスワード
   ▼imori さん:

コードは眺めた程度で、よく読んでいませんが確認です。

まず、階層は1〜4ですか?それとも、いくつあるかわからないのでしょうか?
また、番号はユニークと考えていいですか?
それと、ステータス(C列?)は、あらかじめ何かがOKとかNGが記述されているのですか?
それとも、全く空白で、マクロですべての(1〜4の)ステータスを記入するのですか?
後者だとして、

>4    000008    □(4)・・・下に階層が続かないためステータスは[保留]

これがよくわかりません。階層5 がないのでわからないから保留?
であれば、ここだけではなく、アップされたサンプルの階層4は、すべて保留じゃないですか?

【77102】Re:階層構造のステータスの設定に関して
発言  β  - 15/5/21(木) 19:26 -

引用なし
パスワード
   ▼imori さん:

なんとなくわかったこと。

ステータスが記載されていないところ(空白)のみステータスを記入。
下の階層とは、下のすべての階層ではなく、「1つしたの階層のみ」

ということでしょうか?

【77104】Re:階層構造のステータスの設定に関して
発言  β  - 15/5/21(木) 22:50 -

引用なし
パスワード
   ▼imori さん:

要件をすっかり誤解しているかもしれませんが、とにかく書いてみました。

Sub Test()
  Dim i As Long
  Dim w As Variant
  Dim maxlvl As Long
  Dim oldlvl As Long
  Dim curlvl As Long
  Dim myExists As Boolean
  Dim myHold As Boolean
  Dim myNG As Boolean
  Dim x As Long
  
  maxlvl = WorksheetFunction.Max(Range("A2", Range("A" & Rows.Count).End(xlUp)))
  oldlvl = 1
    
  For i = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
    If oldlvl = 1 Then
      ReDim w(1 To maxlvl, 1 To 3)
      For x = 1 To maxlvl
        w(x, exists) = False
        w(x, hold) = False
        w(x, ng) = False
      Next
    End If
    curlvl = Cells(i, "A").Value
    
    If IsEmpty(Cells(i, "C")) Then
      myExists = False
      myHold = False
      myNG = False
      If curlvl < maxlvl Then
        For x = curlvl + 1 To maxlvl
          If w(x, exists) Then myExists = True
          If w(x, hold) Then myHold = True
          If w(x, ng) Then myNG = True
        Next
      End If
      If myNG Then
        Cells(i, "C").Value = "NG"
      ElseIf myHold Or Not myExists Then
        Cells(i, "C").Value = "保留"
      Else
        Cells(i, "C").Value = "OK"
      End If
    End If
    
    w(curlvl, exists) = True
    If Cells(i, "C").Value = "保留" Then w(curlvl, hold) = True
    If Cells(i, "C").Value = "NG" Then w(curlvl, ng) = True
    
    oldlvl = curlvl
    
  Next
  
End Sub

【77105】Re:階層構造のステータスの設定に関して
発言  β  - 15/5/22(金) 6:55 -

引用なし
パスワード
   ▼imori さん:

おはようございます。

おはようございます

よ〜く考えると、アップしたコードは【欠陥コード】でした。

a 1
b 2
c 3
d 4
e 4
f 3
g 4
h 4
i 4
j 4
k 3
l 4
m 4
n 3

こんな階層があったとして、アップしたコードは階層1 ごとに各階層の状況をリセットしています。
逆にいえば、その間は、すべての階層における NG状況とか保留状況とか階層有無状況を保持。

でも、c の階層3に紐付く階層4は d,e のみですよね。コードでは、g〜j、i,m における状況も
保持されています。なので、d,eがOKでもm,nがNGなら c も(この c のステータスが空白なら) NG になります。

これを、当該階層に紐付く下の階層のみを参照するということは、手を入れれば可能ですが、悩ましいのは
仮に 階層2 の b 判定。ここがステータス空白だったとして、c,f,k,n の階層3を調べればいいのかもしれませんが
階層3の k に 手入力で OK が入っていたとして(そんなことはない?)階層4のlあるいはmがNGだったとすれば
本来は、階層2 の b も NG でしょうけど、k がOKなので、b もOKになってしまう?

そんなことはない、l,m がNGなら k には絶対に手入力で OK はいれないということなら
コードを(かなり)渇変えればできるような気もしますが。

【77106】Re:階層構造のステータスの設定に関して
発言  β  - 15/5/22(金) 8:38 -

引用なし
パスワード
   ▼imori さん:

↑で悩んだことを取り入れてみて・・・
でも、そもそも、要件の理解が間違っている公算大で、自信度10%ぐらいですが・・・

Sub Test2()
  Dim i As Long
  Dim w As Variant
  Dim maxlvl As Long
  Dim oldlvl As Long
  Dim curlvl As Long
  Dim myExists As Boolean
  Dim myHold As Boolean
  Dim myNG As Boolean
  Dim x As Long
  
  maxlvl = WorksheetFunction.Max(Range("A2", Range("A" & Rows.Count).End(xlUp)))
  oldlvl = maxlvl + 1
  
  ReDim w(1 To maxlvl, 1 To 3)
  For x = 1 To maxlvl
    w(x, exists) = False
    w(x, hold) = False
    w(x, ng) = False
  Next
  
  For i = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
    curlvl = Cells(i, "A").Value

    If curlvl > oldlvl Then
      For x = curlvl To maxlvl
        w(x, exists) = False
        w(x, hold) = False
        w(x, ng) = False
      Next
    End If
    
    If IsEmpty(Cells(i, "C")) Then
      myExists = False
      myHold = False
      myNG = False
      If curlvl < maxlvl Then
        For x = curlvl + 1 To maxlvl
          If w(x, exists) Then myExists = True
          If w(x, hold) Then myHold = True
          If w(x, ng) Then myNG = True
        Next
      End If
      If myNG Then
        Cells(i, "C").Value = "NG"
      ElseIf myHold Or Not myExists Then
        Cells(i, "C").Value = "保留"
      Else
        Cells(i, "C").Value = "OK"
      End If
    End If
    
    w(curlvl, exists) = True
    If Cells(i, "C").Value = "保留" Then w(curlvl, hold) = True
    If Cells(i, "C").Value = "NG" Then w(curlvl, ng) = True
    
    oldlvl = curlvl
    
  Next
  
End Sub

【77108】Re:階層構造のステータスの設定に関して
回答  imori  - 15/5/22(金) 10:33 -

引用なし
パスワード
   β さん、
おはようございます。imoriです。

色々と考えていただきありがとうございます。
事前定義の情報が少なくて申し訳ございませんでした。

>まず、階層は1〜4ですか?それとも、いくつあるかわからないのでしょうか?
→階層に関してはいくつあるか分からないですが、今のところ5が最大です。

>また、番号はユニークと考えていいですか?
→番号はユニークではありません。
 別の階層の下に同じ番号がつくケースもあります。

>それと、ステータス(C列?)は、あらかじめ何かがOKとかNGが記述されているのですか?
→階層の末端は基本的にはOK、保留、NGが記載されています。
 記載がない場合は、保留となります。

>それとも、全く空白で、マクロですべての(1〜4の)ステータスを記入するのですか?
>後者だとして、
>
>>4    000008    □(4)・・・下に階層が続かないためステータスは[保留]
>
>これがよくわかりません。階層5 がないのでわからないから保留?
>であれば、ここだけではなく、アップされたサンプルの階層4は、すべて保留じゃないですか?
→前者になります。

>ステータスが記載されていないところ(空白)のみステータスを記入。
>下の階層とは、下のすべての階層ではなく、「1つしたの階層のみ」
左様でございます。
階層1は階層2のステータスにより決定され、
階層2は階層3のステータスにより決定されます。
イメージは以下のようになります。

階層1        階層2        階層3   階層4    
番号        番号        番号       番号    
000001_____________000002__________000003_OK____________000004 OK
           |          |_______________000005 OK
           |
           |_____________000006_____________000007 NG
           |          |____________000008    
           |          |____________000009 NG
           |          |____________000010 OK
           |
           |_____________000011_____________000012 OK
           |          |___________000013 OK
           |
           |_____________000014 OK        
                            
βさん、コード書いていただきありがとうございます。
これから書いていただいたコードを見てみます。

【77109】Re:階層構造のステータスの設定に関して
回答  ウッシ  - 15/5/22(金) 12:03 -

引用なし
パスワード
   こんにちは

こういう事でしょうか?

Sub test()
  Dim h     As Long
  Dim i     As Long
  Dim j     As Long
  Dim k     As Long
  Dim ステータス As String
  Dim mSh    As Worksheet
  Dim wSh    As Worksheet
  Dim r     As Range
  Dim rr     As Range
  
  Set mSh = Worksheets("Sheet1") '元データシート
  Set wSh = Worksheets.Add
  
  With mSh
    j = .Range("A" & Rows.Count).End(xlUp).Row
    k = WorksheetFunction.Max(.Range("A2", .Range("A" & Rows.Count).End(xlUp)))
    .Range("A1").Resize(j, 1).Copy wSh.Range("A1")
  End With
  
  With wSh
    For i = 2 To j
      If .Cells(i, 1) > 1 Then
        .Cells(i, 1).Resize(, .Cells(i, 1) - 1).Insert Shift:=xlToRight
      End If
    Next
    mSh.Range("C1").Resize(j, 1).Copy wSh.Cells(1, k + 2)
    On Error Resume Next
    For h = k To 1 Step -1
      For i = j To 2 Step -1
        If .Cells(i, h) <> "" Then
          If .Cells(i, k + 2) = "" Then
            ステータス = ""
            Set r = _
              .Range(.Cells(i, h + 1), .Cells(j, h + 1)) _
              .SpecialCells(xlCellTypeConstants)
            If r Is Nothing Then
              ステータス = "保留"
            Else
              For Each rr In r
                If rr.EntireRow.Cells(1, k + 2) = "NG" Then
                  ステータス = "NG"
                ElseIf rr.EntireRow.Cells(1, k + 2) = "保留" Then
                  If ステータス <> "NG" Then
                    ステータス = "保留"
                  End If
                ElseIf rr.EntireRow.Cells(1, k + 2) = "OK" Then
                  If ステータス = "" Then
                    ステータス = "OK"
                  End If
                End If
              Next
            End If
            .Cells(i, k + 2) = ステータス
          End If
        End If
      Next
    Next
    On Error GoTo 0
    .Cells(1, k + 2).Resize(j).Copy mSh.Range("C1")
  End With
  Application.DisplayAlerts = False
  wSh.Delete
  Application.DisplayAlerts = True
  
End Sub

一時シートに階層をビジュアル的に再セットしてから処理しています。

【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

【77142】Re:階層構造のステータスの設定に関して
お礼  imori  - 15/5/23(土) 22:12 -

引用なし
パスワード
   ▼β さん:

imoriです。
ソースコードを読み解いていたらお返事遅くなってしまいました。
まだ過去のソースコードを読み解いている最中なのですが・・・。

新しいソースコードありがとうございます。
まだ、理解する段階まではいってないのですが、
期待する通りの結果に動いており、感動しています。
手でやったほうが早いのではないかと諦めかけていましたので・・・・。
本当にありがとうございます。とても勉強になります。
これからもう少しソースコードを読み解いてみたいと思います。

【77143】Re:階層構造のステータスの設定に関して
お礼  imori  - 15/5/23(土) 23:28 -

引用なし
パスワード
   ▼ウッシ さん:
こんばんは。

ソースコードを書いていただきありがとうございます。
まだ現在読み解いている最中ではあるのですが、動かしてみました。
ビジュアル的に動きが分かりやすく、こういうやり方もあるのかと感動しました。
まだ、ソースを理解するには至っていないので、
読み解けましたら、またご連絡いたします。

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