GDIplusCODE

Sub test()
  'H列を対象にしています
  Dim targetRange As Range, myCell As Range, myArea As Range, topCell As Range
  Dim connectionArea As Range, connectionColumn As Range
  Dim myDic As Object, myKey As Variant
  Dim lineOffset As Long, myColor As Long
  Dim lineLength As Double
  Dim shp As Shape

  For Each shp In ActiveSheet.Shapes: shp.Delete: Next shp
  lineLength = 10
  Set targetRange = Range(Range("H1"), Range("H" & Rows.Count).End(xlUp))
  Set myDic = CreateObject("Scripting.Dictionary")
  For Each myCell In targetRange.Cells
    If myDic.exists(myCell.Value) Then
      Set myDic.Item(myCell.Value) = Union(myCell, myDic.Item(myCell.Value))
    Else
      myDic.Add myCell.Value, myCell
    End If
  Next myCell
  For Each myKey In myDic.keys
    If myDic.Item(myKey).Cells.Count > 1 Then
      '縦線を引く位置を決定 セルのIntersectで干渉を判別
      '作業用配列の干渉を判別できる関数かクラスでも作成しても同じ事は出来るであろう
      For Each myArea In myDic.Item(myKey)
        For Each myCell In myArea
          If topCell Is Nothing Then
          Set topCell = myCell
          Else
            If connectionColumn Is Nothing Then
              Set connectionColumn = Range(topCell, myCell)
            Else
              Set connectionColumn = Union(connectionColumn, Range(topCell, myCell))
            End If
          End If
        Next myCell
      Next myArea
      lineOffset = 2
      Set connectionColumn = connectionColumn.Offset(0, lineOffset)
      If Not connectionArea Is Nothing Then
        Do Until Intersect(connectionColumn, connectionArea) Is Nothing
          lineOffset = lineOffset + 1
          Set connectionColumn = connectionColumn.Offset(0, 1)
        Loop
        Set connectionArea = Union(connectionArea, connectionColumn)
      Else
        Set connectionArea = connectionColumn
      End If
      Set topCell = Nothing: Set connectionColumn = Nothing
      '線を引く
      myColor = RGB(Int(Rnd() * 256), Int(Rnd() * 256), Int(Rnd() * 256))
      For Each myArea In myDic.Item(myKey)
        For Each myCell In myArea
          If topCell Is Nothing Then
          Set topCell = myCell
          Else
            Call connectCell2(topCell.Offset(0, 1), myCell.Offset(0, 1), lineLength + lineOffset * 10, myColor)
          End If
        Next myCell
      Next myArea
    End If
  Next myKey
  Set connectionArea = Nothing
  Set myDic = Nothing
End Sub

Private Sub connectCell2(upperCell As Range, lowerCell As Range, lineLength As Double, myColor As Long)
  Dim rect1 As Shape, rect2 As Shape, connectLine As Shape
  
  With upperCell
    Set rect1 = ActiveSheet.Shapes.AddShape(msoShapeRectangle, .Left, .Top, .Width, .Height)
  End With
  With lowerCell
    Set rect2 = ActiveSheet.Shapes.AddShape(msoShapeRectangle, .Left, .Top, .Width, .Height)
  End With
  Set connectLine = ActiveSheet.Shapes.AddConnector(msoConnectorElbow, 0, 0, 10, 10)
  connectLine.ConnectorFormat.BeginConnect rect1, 4
  connectLine.ConnectorFormat.EndConnect rect2, 4
  connectLine.Adjustments.Item(1) = lineLength
  connectLine.Line.ForeColor.RGB = myColor
  rect1.Delete
  rect2.Delete
End Sub
列内の同じ値のセルを線で結ぶ
