Excel VBA質問箱 IV

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

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


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

5236 / 76732

←次へ　｜　前へ→


	【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

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

289 hits

▼

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