FC2ブログ

スポンサーサイト 


上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

親子関係もどきのブロック図化 


知恵袋で、親子関係もどきの辿り方を回答後、以下の質問を受けました

いつもお世話になっております。

q10185679650_1.jpg

このデータを元に、F 列の情報と、AB 列の関係性をブロック図で表したい・・・

q10185679650_2.jpg

やったこと無い分野で、興味もあったのでやってみた
サンプルファイルは、2/4 に入手していたけど・・・
まとめて時間が取れない平日は、処理の方向性・・・頭の中で色々動かしてみて・・・
・表の始まりは、最上位ではない・・・とか
・重複する行もある・・・ 6 と 7 / 21 と 22
・再帰的な部分がある・・・とか

当初は、分岐・合流・・・この部分を求めつつ、その間を埋めていく・・・
けど、しっくりこない・・・

そこで、最上位から順に1段ずつ張り付けていく方法にしてみた
まとまった時間が取れた3連休でコード化してみて・・・
雪かきとか、オリンピック応援とか・・・あったけど
入手したサンプルでは、それなりの形になったかな・・・

q10185679650_R1.jpg

罫線を表示してみると

q10185679650_R2.jpg

図形は使わずに、セルの大きさを変更しながら・・・セル結合しながら・・・

でも、チョットパターンが変わるとグチャグチャになるのは目に見えていて・・・
・合流部分が違う段に出現したら・・・・とか
・同じ段に異なる分野のものが並んだ際、段をズラす順は・・・とか
 同じ分野はまとめたいよね・・・
・・・この辺の処理を盛り込まないと、実際には使い物にならない???

複数パターンをお願いした結果が、1パターンだけだったので・・・
そのパターンで、そこそこ出来たから良しとしようか・・・・

ということで、
回答の文字数制限は軽くオーバしているので、ファイルを渡すための記事になります
 
一応、現状記述した内容も紹介しておきます

なお、このサンプルでは動いていない部分の処理・・・抜けたままになってます
そこには、・・・ 処理漏れ部分★★ ・・・ としてました

Option Explicit

Private Const CSM As String = "開始"
Private Const CEM As String = "終了"
Dim dic As Object, dicR As Object, dicD As Object
Dim vBF As Variant, vBFw As Variant, vAB As Variant
Dim rngB As Range


Public Sub SampZ()
  Call dicInit(True)

  If (fncData2Dic) Then
    Call dic2Pos
'' ~~ Debug
'  Dim vK As Variant
'  Debug.Print "dicR >>"
'  For Each vK In dicR.Keys
'    Debug.Print vK, Join(dicR(vK).Keys, ", ")
'  Next
'  Debug.Print
'  Debug.Print "dicD >>"
'  For Each vK In dicD.Keys
'    Debug.Print vK, Join(dicD(vK), " : ")
'  Next
'' ~~
    Call dic2Sheet
  End If

  Call dicInit
End Sub

Private Sub dicInit(Optional ByVal bV As Boolean = False)
  If (bV) Then
    Set dic = CreateObject("Scripting.Dictionary")
    Set dicR = CreateObject("Scripting.Dictionary")
    Set dicD = CreateObject("Scripting.Dictionary")
  Else
    Set dic = Nothing
    Set dicR = Nothing
    Set dicD = Nothing
  End If
End Sub


' データを入手し、dic に情報構築
'
Private Function fncData2Dic() As Boolean
  Dim dicU As Object, dicW As Object
  Dim v As Variant
  Dim j As Long

  With Worksheets("リスト")
    With .Range("A3", .Cells(Rows.Count, "A").End(xlUp))
      With .EntireRow
        With .Columns("B:F")
          vBF = .Value
          ReDim vBFw(1 To .Columns.Count)
          For j = 1 To .Columns.Count
            v = .Cells(j).ColumnWidth
            vBFw(j) = (Int(v + 1) \ 2) * 2
          Next
        End With
        vAB = .Columns("AB").Value
      End With
    End With
  End With

  Set dicU = fncUsedID
  If (dicU.Count = 0) Then
    fncData2Dic = False
  Else
    fncData2Dic = True
    Call MakeDic(dicU)
  End If
  Set dicU = Nothing
End Function


' 次工程「終了」から逆に辿り、繋がっている「ID」のみをバフッと抽出
' その情報を Dictionary で返す
'
Private Function fncUsedID() As Object
  Dim dicP As Object, dicN As Object, dicU As Object, dicW As Object
  Dim i As Long

  Set dicN = CreateObject("Scripting.Dictionary")
  Set dicP = CreateObject("Scripting.Dictionary")
  Set dicU = CreateObject("Scripting.Dictionary")

  For i = 2 To UBound(vBF)
    If (vBF(i, 5) = "") Then vBF(i, 5) = vBF(i - 1, 5)
    vAB(i, 1) = fncNextID(vAB(i, 1))
    If (vAB(i, 1) <> "") Then
      If (dicP.Exists(vAB(i, 1))) Then
        Set dicW = dicP(vAB(i, 1))
        dicW(vBF(i, 5)) = Empty
      Else
        Set dicW = CreateObject("Scripting.Dictionary")
        dicW(vBF(i, 5)) = Empty
        dicP.Add vAB(i, 1), dicW
      End If

      If (dicN.Exists(vBF(i, 5))) Then
        Set dicW = dicN(vBF(i, 5))
        dicW(vAB(i, 1)) = Empty
      Else
        Set dicW = CreateObject("Scripting.Dictionary")
        dicW(vAB(i, 1)) = Empty
        dicN.Add vBF(i, 5), dicW
      End If
    End If
  Next
  If (Not dicN.Exists(CEM)) Then
    dicN.Add CEM, CreateObject("Scripting.Dictionary")
  End If

  If (dicP.Exists(CEM)) Then
    Call dicCheckPrev(dicN, dicP, dicU, CEM)
  End If
  Set fncUsedID = dicU
  Set dicN = Nothing
  Set dicP = Nothing
  Set dicW = Nothing
End Function

Private Function fncNextID(ByVal sSrc As String) As String
  Const CM As String = ":"

  If (sSrc Like "【*】") Then
    sSrc = Mid(sSrc, 2, Len(sSrc) - 2)
    sSrc = Mid(sSrc, InStrRev(CM & sSrc, CM))
  ElseIf (sSrc <> CEM) Then
    sSrc = ""
  End If
  fncNextID = sSrc
End Function

Private Sub dicCheckPrev(dicN As Object, dicP As Object _
          , dicU As Object, ByVal sSrc As String)
  Dim vK As Variant

  For Each vK In dicP(sSrc).Keys
    Call dicCheckNext(dicN, dicP, dicU, vK)
  Next
End Sub

Private Sub dicCheckNext(dicN As Object, dicP As Object _
          , dicU As Object, ByVal sSrc As String)
  Dim vK As Variant

  If (dicU.Exists(sSrc)) Then Exit Sub
  dicU(sSrc) = Empty
  For Each vK In dicN(sSrc).Keys
    If (dicN.Exists(vK)) Then
      Call dicCheckNext(dicN, dicP, dicU, vK)
    End If
  Next
  If (dicP.Exists(sSrc)) Then
    Call dicCheckPrev(dicN, dicP, dicU, sSrc)
  End If
End Sub


' メイン dic 構築
'
Private Sub MakeDic(dicU As Object)
  Dim dicE(1) As Object, dicW As Object
  Dim vCSM As Variant
  Dim vK As Variant, v As Variant, vW As Variant
  Dim sS As String
  Dim i As Long, j As Long, k As Long, n As Long

  Set dicE(0) = CreateObject("Scripting.Dictionary")
  Set dicE(1) = CreateObject("Scripting.Dictionary")
  Set dicW = CreateObject("Scripting.Dictionary")

  vBF(1, 4) = vBF(1, 5) & " / " & vBF(1, 4)
  For i = 2 To UBound(vBF)
    If (dicU.Exists(vBF(i, 5)) And dicU.Exists(vAB(i, 1))) Then
      If (Not dic.Exists(vBF(i, 5))) Then
        vBF(i, 4) = vBF(i, 5) & vbLf & vBF(i, 4)
        sS = vBF(i, 1) & vbTab & vBF(i, 2) & vbTab & vBF(i, 3)
        dic(vBF(i, 5)) = Array(sS, i _
            , CreateObject("Scripting.Dictionary") _
            , CreateObject("Scripting.Dictionary") _
            , CreateObject("Scripting.Dictionary"))
      End If
    End If
  Next
  dic(CEM) = Array(Empty, 0 _
      , CreateObject("Scripting.Dictionary") _
      , CreateObject("Scripting.Dictionary") _
      , CreateObject("Scripting.Dictionary"))
  vCSM = Array(Empty, 0 _
      , CreateObject("Scripting.Dictionary") _
      , CreateObject("Scripting.Dictionary") _
      , CreateObject("Scripting.Dictionary"))

  For i = 2 To UBound(vBF)
    If (dic.Exists(vBF(i, 5)) And dic.Exists(vAB(i, 1))) Then
      dic(vBF(i, 5))(2)(vAB(i, 1)) = Empty
    End If
  Next

  For Each vK In dic.Keys
    For Each v In dic(vK)(2).Keys
      dic(v)(3)(vK) = Empty
    Next
  Next

  For Each vK In dic.Keys
    If (dic(vK)(3).Count = 0) Then
      vCSM(2)(vK) = Empty
      dic(vK)(3)(CSM) = Empty
    End If
  Next
  dic(CSM) = vCSM

  i = 0
  dicE(i)(CSM) = Empty
  While (dicE(i).Count > 0)
    j = i: i = 1 - i
    For Each vK In dicE(j).Keys
      For Each v In dic(vK)(3).Keys
        If (Not dicW.Exists(v)) Then
          dic(vK)(3).Remove v
          dic(v)(2).Remove vK
          dic(v)(4)(vK) = Empty
        End If
      Next
      dicW(vK) = Empty
    Next
    dicE(i).RemoveAll
    For Each vK In dicE(j).Keys
      For Each v In dic(vK)(2).Keys
        If (v <> CEM) Then dicE(i)(v) = Empty
      Next
    Next
  Wend

'' ~~ Debug
'  For Each vK In dic.Keys
'    Debug.Print vK
'    Debug.Print " >Next "; Join(dic(vK)(2).Keys, ", ")
'    Debug.Print " >Prev "; Join(dic(vK)(3).Keys, ", ")
'    Debug.Print " >ReNext "; Join(dic(vK)(4).Keys, ", ")
'  Next
'' ~~
  Erase dicE
  Set dicW = Nothing
End Sub


' メイン dic から表示位置策定
'
Private Sub dic2Pos()
  Dim dicE(1) As Object, dicW As Object
  Dim vK As Variant, v As Variant, vW As Variant
  Dim i As Long, j As Long, n As Long
  Dim jCb As Long, jC As Long
  Dim jRb As Long, jR As Long

  Set dicE(0) = CreateObject("Scripting.Dictionary")
  Set dicE(1) = CreateObject("Scripting.Dictionary")

  jCb = 0
  i = 0
  dicE(i)(CSM) = Empty
  While (dicE(i).Count > 0)
    j = i: i = 1 - i
    dicE(i).RemoveAll
    jRb = dicR.Count
    If (dicE(j).Count = 1) Then
      v = dicE(j).Keys()(0)
      Call fnc1Push(v, jRb, jCb)
    Else
      For Each vK In dicE(j).Keys
        v = dic(vK)(0)
        dicE(i)(v) = Empty
      Next
      n = 0
      If (dicE(i).Count > 1) Then n = 1
      jR = 0: jC = 0
      For Each vK In dicE(j).Keys
        If (fnc1Push(vK, jRb + jR, jCb + jC)) Then
          ' 処理漏れ部分★★(サンプルにこの処理は無い)
          ' なお、縦に並べる・・・変更はここ近辺
        End If
        jR = jR + n
        jC = jC + 1
      Next
    End If

    dicE(i).RemoveAll
    For Each vK In dicE(j).Keys
      For Each v In dic(vK)(2).Keys
        If (v = CEM) Then
          jCb = 1
        Else
          dicE(i)(v) = Empty
        End If
      Next
    Next
  Wend
  Call fnc1Push(CEM, dicR.Count, 0)

  Erase dicE
  Set dicW = Nothing
End Sub

Private Function fnc1Push(ByVal sID As String _
        , jR As Long, jC As Long) As Boolean
  Dim dicW As Object
  Dim vK As Variant, v As Variant
  Dim i As Long, j As Long, k As Long

  fnc1Push = False
  If (dicD.Exists(sID)) Then
    ' 処理漏れ部分★★(サンプルにこの処理は無い)
  Else
    If (dicR.Exists(jR)) Then
      Set dicW = dicR(jR)
      dicW(sID) = Empty
    Else
      Set dicW = CreateObject("Scripting.Dictionary")
      dicW(sID) = Empty
      dicR.Add jR, dicW
    End If
    dicD(sID) = Array(jR, jC)
  End If

  Set dicW = Nothing
End Function



' 結果のシートへの書き出し
'
Private Sub dic2Sheet()
  Dim ws As Worksheet

  Application.ScreenUpdating = False
  Set ws = Worksheets.Add
  Call SheetForm(ws)
  Call PictLine
  Application.Goto ws.Range("A1"), True
  ActiveWindow.DisplayGridlines = False
  Application.ScreenUpdating = True
End Sub


Private Sub SheetForm(ws As Worksheet)
  Dim rng As Range, r As Range
  Dim vK As Variant, v As Variant
  Dim vR As Variant, vC As Variant
  Dim jR As Long, jC As Long
  Dim i As Long, j As Long, k As Long, n As Long
  Const CRNG As String = "B1,D1,F1,H1"
  Const CSR As Long = 4 ' 書き出し行

  jR = 0: jC = 0
  For Each vK In dicD.Keys
    v = dicD(vK)
    If (v(0) > jR) Then jR = v(0)
    If (v(1) > jC) Then jC = v(1)
  Next

  With ws
    v = .Cells(1).RowHeight
    vR = Array(v / 2, v / 2, v, v, v / 2, v / 2)
    v = vBFw(4)
    If (vBFw(5) > v) Then v = vBFw(5)
    v = v \ 2
    vC = Array(1, v - 1, 1, 1, v - 1, 1)
    i = UBound(vR) + 1
    j = UBound(vC) + 1
    With .Rows(CSR).Range(CRNG)
      For k = 1 To .Areas.Count - 1
        With .Areas(k).Cells
          .Value = vBF(1, k)
          .ColumnWidth = vBFw(k)
          .Offset(, 1).ColumnWidth = 1
          .Borders.LineStyle = xlContinuous
        End With
      Next
      With .Areas(k).Cells
        Set rngB = .Offset(1).Resize(i, j)
        With .Resize(, (jC + 1) * j)
        .Merge
          .Value = vBF(1, k)
          .Borders.LineStyle = xlContinuous
        End With
      End With
    End With

    With rngB
      For k = 0 To jR
        With .Offset(k * i)
          For n = 1 To i
            .Cells(n, 1).RowHeight = vR(n - 1)
          Next
        End With
      Next
      For k = 0 To jC
        With .Offset(, k * j)
          For n = 1 To j
            .Cells(1, n).ColumnWidth = vC(n - 1)
          Next
        End With
      Next
    End With

    For Each vK In dicD.Keys
      k = dic(vK)(1)
      v = dicD(vK)
      Set rng = rngB.Offset(v(0) * i, v(1) * j)
      If (dicR.Exists(v(0))) Then
        If (k > 0) Then
          With Intersect(.Range(CRNG).EntireColumn, rng.Rows("3:4").EntireRow)
            For n = 1 To 3
              .Areas(n).Value = vBF(k, n)
            Next
          End With
        End If
        dicR.Remove v(0)
      End If
      With rng.Cells(3, 2).Resize(2, 4)
        .Merge
        If (k = 0) Then
          .Value = vK
        Else
          .Value = vBF(k, 4)
        End If
        .Borders.LineStyle = xlContinuous
      End With
    Next

    Application.DisplayAlerts = False
    With .Range(CRNG)
      For i = 1 To 3
        Set rng = Nothing
        For Each r In .Areas(i).EntireColumn.SpecialCells(xlCellTypeConstants).Areas
          If (r(1).Row > CSR) Then
            If (rng Is Nothing) Then
              Set rng = r
            ElseIf (rng(1).Value <> r(1).Value) Then
              With rng
                .Merge
                .Borders.LineStyle = xlContinuous
              End With
              Set rng = r
            Else
              Set rng = Range(rng(1), r(2))
            End If
          End If
        Next
        With rng
          .Merge
          .Borders.LineStyle = xlContinuous
        End With
      Next
    End With
    Application.DisplayAlerts = True

    .Cells.HorizontalAlignment = xlCenter
  End With
End Sub


Private Sub PictLine()
  Dim dicE(1) As Object
  Dim vK As Variant, v As Variant
  Dim i As Long, j As Long

  Set dicE(0) = CreateObject("Scripting.Dictionary")
  Set dicE(1) = CreateObject("Scripting.Dictionary")

  i = 0
  dicE(i)(CSM) = Empty
  While (dicE(i).Count > 0)
    j = i
    i = 1 - i
    dicE(i).RemoveAll
    For Each vK In dicE(j).Keys
      For Each v In dic(vK)(2).Keys
        dicE(i)(v) = Empty
        Call PictNextLine(dicD(vK), dicD(v))
      Next
      For Each v In dic(vK)(4).Keys
        Call PictReNextLine(dicD(vK), dicD(v))
      Next
    Next
  Wend

  Erase dicE
End Sub


Private Sub PictNextLine(vS As Variant, vE As Variant)
  Dim rS As Range, rE As Range
  Dim i As Long, j As Long

  i = rngB.Rows.Count
  j = rngB.Columns.Count
  Set rS = rngB.Offset(vS(0) * i, vS(1) * j).Cells(5, 4)
  Set rE = rngB.Offset(vE(0) * i, vE(1) * j).Cells(2, 4)
  Select Case True
    Case vS(1) = vE(1)
      With Range(rS, rE)
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
      End With
    Case vS(1) < vE(1)
      With Range(rS, rE.Offset(, -1))
        With .Rows(1).Resize(2)
          .Borders(xlEdgeLeft).LineStyle = xlContinuous
        End With
        With .Rows(3).Resize(.Rows.Count - 2)
          .Borders(xlEdgeTop).LineStyle = xlContinuous
          .Borders(xlEdgeRight).LineStyle = xlContinuous
        End With
      End With
    Case vS(1) > vE(1)
      With Range(rS.Offset(, -1), rE)
        With .Rows(1).Resize(2)
          .Borders(xlEdgeRight).LineStyle = xlContinuous
        End With
        With .Rows(3).Resize(.Rows.Count - 2)
          .Borders(xlEdgeTop).LineStyle = xlContinuous
          .Borders(xlEdgeLeft).LineStyle = xlContinuous
        End With
      End With
  End Select
End Sub

Private Sub PictReNextLine(vS As Variant, vE As Variant)
  Dim rS As Range, rE As Range
  Dim i As Long, j As Long

  i = rngB.Rows.Count
  j = rngB.Columns.Count
  Set rS = rngB.Offset(vS(0) * i, vS(1) * j).Cells(5, 5)
  Set rE = rngB.Offset(vE(0) * i, vE(1) * j).Cells(2, 5)
  Select Case True
    Case vS(1) = vE(1)
      With Range(rS, rE).Resize(, 2)
        With .Borders(xlEdgeTop)
          .LineStyle = xlContinuous
          .ColorIndex = 3
        End With
        With .Borders(xlEdgeBottom)
          .LineStyle = xlContinuous
          .ColorIndex = 3
        End With
        With .Borders(xlEdgeRight)
          .LineStyle = xlContinuous
          .ColorIndex = 3
        End With
      End With
      With rS.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 3
      End With
      With rE.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 3
      End With
    Case vS(1) < vE(1)
      With Range(rS, rE.Offset(, -3))
        With .Columns(3).Resize(, .Columns.Count - 2)
          With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 3
          End With
        End With
        With .Columns(1).Resize(, 2)
          With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 3
          End With
          With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 3
          End With
        End With
      End With
      With rS.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 3
      End With
      With rE.Offset(, -3).Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 3
      End With
    Case vS(1) > vE(1)
      With Range(rS.Offset(, 1), rE)
        With .Borders(xlEdgeTop)
          .LineStyle = xlContinuous
          .ColorIndex = 3
        End With
        With .Borders(xlEdgeRight)
          .LineStyle = xlContinuous
          .ColorIndex = 3
        End With
        With rS.Resize(, 2)
          With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 3
          End With
        End With
      End With
      With rS.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 3
      End With
      With rE.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 3
      End With
  End Select
End Sub

 
サンプルは以下
 バージョン 2000 でも
 ファイル q10185679650.zip
 サイズ 172,013
※ ファイルは zip 形式
※ 2007 で作成した Excel ファイル(互換:xls と xlsm)



※ 久しぶりに記事書いたので・・・結構手間取った
関連記事

2018/02/13

Category: Excel VBA

TB: --  /  CM: 1

top △

この記事に対するコメント

本当にいつもありがとうございます。

kikuさんは本当にすごい!
神様みたいな存在です。

ありがとうございます。。。

#- | URL | 2018/02/13 23:29 * edit *

top △

コメントの投稿

Secret

top △


上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。