Sub Waritsuke()
  Worksheets("waritsuke").Activate
  ActiveSheet.DrawingObjects.Delete
  Dim Sheet1 As Variant
  Sheet1 = "rcpsp42"
  Dim time1 As Integer, time2 As Integer, sp As Integer
  time1 = 2: time2 = 10: sp = 7:
  Dim act As Variant, mode As Variant, ID As Integer, no As Integer
  Dim joban As Integer, sx As Integer, sy As Integer, tx As Integer
  Dim ty As Integer, start As Integer, completion As Integer
  Dim S As Range, Q As Shape
  For i = 2 To 14
    act = Worksheets(Sheet1).Cells(i, 1) 'MsgBox (act)
    act = Mid(act, 8, 3)
    mode = Worksheets(Sheet1).Cells(i, 2)
    ID = Len(mode)
    If ID = 21 Then
      sx = Val(Mid(mode, 9, 2))
      sy = Val(Mid(mode, 12, 2))
      tx = Val(Mid(mode, 16, 2))
      ty = Val(Mid(mode, 19, 2))
      start = Worksheets(Sheet1).Cells(i, 3) + 1
      completion = Worksheets(Sheet1).Cells(i, 5)
      For j = start - time1 To completion - time1
        Set S = Range(Cells(3 + sp * j + sx, 4 + 1 + sy), _
        Cells(2 + sp * j + sx + tx, 3 + 1 + sy + ty))
        Set Q = ActiveSheet.Shapes.AddShape(1, S.Left, S.Top, _
        S.Width, S.Height)
        Q.Select
        ic = i Mod 6
        Selection.Font.ColorIndex = 1
        If ic = 0 Then
          Q.Fill.ForeColor.RGB = RGB(255, 0, 0)  '赤
        ElseIf ic = 1 Then
          Q.Fill.ForeColor.RGB = RGB(0, 255, 0)  '緑
        ElseIf ic = 2 Then
          Q.Fill.ForeColor.RGB = RGB(0, 0, 255)  '青
          Selection.Font.ColorIndex = 2
        ElseIf ic = 3 Then
          Q.Fill.ForeColor.RGB = RGB(255, 255, 0) '黄
        ElseIf ic = 4 Then
          Q.Fill.ForeColor.RGB = RGB(0, 255, 255) 'シアン
        ElseIf ic = 5 Then
          Q.Fill.ForeColor.RGB = RGB(255, 0, 255) 'マジェンダ
        End If
        Selection.Text = act
        Selection.Font.Size = 7
      Next j
    End If
  Next i
End Sub