Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
980 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【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、保留があり、ステータス決定のルールは以下の通りです。
１．番号の下に階層が存在しない場合でステータスがブランクの場合は[保留]
２．番号の下に階層が存在しており、一つでもNGがあれば、上のステータスは[NG]
３．番号の下に階層が存在しており、NGがなく、一つでも保留があれば上のステータスは[保留]
４．番号の下に階層が存在しており、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) = "保留"
　　'行の次の行の階層が+１の場合は下に階層がある
　　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 さん：

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

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

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

これがよくわかりません。階層5 がないのでわからないから保留？
であれば、ここだけではなく、アップされたサンプルの階層４は、すべて保留じゃないですか？
【77102】Re:階層構造のステータスの設定に関して
発言  β  - 15/5/21(木) 19:26 -
引用なし
パスワード
   ▼imori さん：

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

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

ということでしょうか？
【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です。

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

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

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

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

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

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

階層１　　　　　　　　階層２　　　　　　　　階層３　　　階層４　　　　
番号　　　　　　　　番号　　　　　　　　番号 　　　　　　番号　　　　
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 -
引用なし
パスワード
   ▼ウッシ さん：
こんばんは。

ソースコードを書いていただきありがとうございます。
まだ現在読み解いている最中ではあるのですが、動かしてみました。
ビジュアル的に動きが分かりやすく、こういうやり方もあるのかと感動しました。
まだ、ソースを理解するには至っていないので、
読み解けましたら、またご連絡いたします。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
980 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free