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

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