|
こんにちは
こういう事でしょうか?
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
一時シートに階層をビジュアル的に再セットしてから処理しています。
|
|