指定した2つの日付セルの間に長方形の図形を貼るマクロ

エクセルで日程表を作る際に開始日と終了日2つの指定した4つの日付の間に4種類の図形を貼るマクロを教えてくださいませんか

No.2 回答者： fujillin 回答日時： 2017/12/06 11:19

こんにちは

補足説明があるのかと思いましたが、補足は無さそうなのと添付図がよく見えないので、わからないところはかなり適当に想定しています。

・表中の日付はすべてシリアル値で、かつ、項目の右側の日付は左から昇順に並んでいるものと仮定。
・表のセル位置等が不明なので、勝手に想定。
・描く図形のサイズ等が不明なので、#1様の意見を取り入れさらに色も変えています。


※ 添付図は図に示される表に対して、以下のマクロを実行した例

Sub Sample()
Dim rw As Long, dCount As Long, i As Integer, j As Long
Dim dRange As Range
Dim color, dStart, dEnd
Dim cStart As Long, cEnd As Long
Dim rTop As Single, rHeight As Single
Dim ht As Single, hh As Single
Dim wl As Single, ww As Single

color = Array(RGB(230, 50, 80), RGB(20, 120, 230), RGB(0, 150, 120), RGB(200, 170, 30))
dCount = Cells(3, Columns.Count).End(xlToLeft).Column - 9
If dCount < 2 Then Exit Sub
Set dRange = Cells(3, 10).Resize(1, dCount)

For rw = 4 To Cells(Rows.Count, 1).End(xlUp).Row
　rTop = Rows(rw).Top
　rHeight = Rows(rw).Height

　For i = 0 To 3
　　dStart = Cells(rw, i * 2 + 2).Value
　　dEnd = Cells(rw, i * 2 + 3).Value

　　If (VarType(dStart) <> vbDate) Or (VarType(dEnd) <> vbDate) Or _
　　　(dStart > dRange(dCount).Value) Or (dEnd < dRange(1).Value) Or _
　　　(dStart > dEnd) Then Exit For
　　For j = 1 To dCount
　　　If dEnd >= dRange(j).Value Then cEnd = j
　　Next j
　　For j = dCount To 1 Step -1
　　　If dStart <= dRange(j).Value Then cStart = j
　　Next j

　　ht = (i * 2 + 1) * rHeight / 10 + rTop
　　hh = rHeight / 5
　　wl = dRange(cStart).Left
　　ww = dRange(cEnd).Left + dRange(cEnd).Width - wl

　　With ActiveSheet.Shapes.AddShape(msoShapeRectangle, wl, ht, ww, hh)
　　　.Fill.Visible = msoTrue
　　　.Fill.ForeColor.RGB = color(i)
　　　.Fill.Transparency = 0
　　　.Fill.Solid
　　　.Line.Visible = msoFalse
　　End With
　Next i
Next rw
End Sub

No.1 回答者： yokomaya 回答日時： 2017/12/04 02:01

もっと丁寧に説明しましょうよ。

4つの日付の間に4種類の図形って何ですか？
日付は行当たり８っつあるように見えるんですけど。

図形って自分で描いてるんだから、
どの図形をどう使ったのか、オーバーラップは
どう処理するのか、ちゃんと示しましょう。

そもそも太さをこのように変える意義って何ですか？

オーバーラップがあるなら高さをそれぞれ少しずつ
ずらせた直線にすれば重なりを
どうするかとかの考慮は必要ありません。

それに項目００４かな？小さくてちゃんと読めないけど
それだけ開始日が５月って何？
どうしたいの？