Excel2010でデータから図形を作成したい

Question

前提・実現したいこと

閲覧ありがとうございます。
現在Excel2010を使用し、入力フォームを作成しています。
そこでVBAを使用し、入力フォームを作成しました。
入力フォームから入力したデータを使用し、マップを作成しようと考えています。
必要な項目はコンボボックスで作成し、Start・Endはテキストボックスで作成し、入力してもらう。
出力結果は以下のように列持ちのデータにします。
Year・Start・Endはそれぞれ2017年・2018年・2021年・2024年となります。
画像のような形のマップを作成したいと思っています。
行いたい処理
・列持ちのデータからStartとEndのデータを取得し、差分を計算し長方形を作成。
・長方形の中に季節のデータを表示させ、適用or未適用が適用であれば色を塗りつぶす。未適用なら
塗りつぶさない。
・図のように一番下にはStartとEndのデータが表示される。
・種類が異なれば次の行に長方形を表示させるような形です。
|地域|地方|果物|種類|季節|適用or未適用|Year|Start|End
|:--|:--:|--:|
|日本|関東|りんご|おいらせ|秋|適用|17|18|21|
|日本|関東|りんご|おいらせ|春|適用|20|21|24|
|日本|関東|りんご|あかぎ|秋|未適用|20|21|24|

発生している問題・エラーメッセージ

入力したデータから長方形を作成したい。
※StartとEndの数値から長さを求め、その長さで長方形を作成する。
ネットで調べた限りそのような情報が見当たりませんでした。

該当のソースコード

Option Explicit
Private lastRow As Long


'ユーザーフォームの説明(Text形式のデータ以外・入力もできるようコンボボックス)
Private Sub UserForm_Initialize()
    'コンボボックスで地域を選択させる
    cmbArea.Style = fmStyleDropDownCombo
    cmbArea.RowSource = ""
    cmbArea.Clear
    cmbArea.AddItem "インド"
    cmbArea.AddItem "インドネシア"
    cmbArea.AddItem "タイ"
    cmbArea.AddItem "ブラジル"
    cmbArea.AddItem "マレーシア"
    cmbArea.AddItem "欧州"
    cmbArea.AddItem "中国"
    cmbArea.AddItem "日本"
    cmbArea.AddItem "北米"
    cmbArea.ListIndex = -1
    
    'コンボボックスで地方を選択させる
    cmbRegion.Style = fmStyleDropDownCombo
    cmbRegion.RowSource = ""
    cmbRegion.Clear
    cmbRegion.AddItem "関東"
    cmbRegion.AddItem "ジョージア州"
    cmbRegion.ListIndex = -1
    
    'コンボボックスで果物を選択させる
    cmbFruit.Style = fmStyleDropDownCombo
    cmbFruit.RowSource = ""
    cmbFruit.Clear
    cmbFruit.AddItem "りんご"
    cmbFruit.AddItem "みかん"
    cmbFruit.ListIndex = -1
    
    'コンボボックスで種類を選択させる
    cmbType.Style = fmStyleDropDownCombo
    cmbType.RowSource = ""
    cmbType.Clear
    cmbType.AddItem "温州"
    cmbType.AddItem "おいらせ"
    cmbType.ListIndex = -1

　　'コンボボックスで季節を選択させる
    cmbSeason.Style = fmStyleDropDownCombo
    cmbSeason.RowSource = ""
    cmbSeason.Clear
    cmbSeason.AddItem "春"
    cmbSeason.AddItem "秋"
    cmbSeason.ListIndex = -1
    
    'コンボボックスで適用or未適用を選択させる
    cmbApplication.Style = fmStyleDropDownCombo
    cmbApplication.RowSource = ""
    cmbApplication.Clear
    cmbApplication.AddItem "適用"
    cmbApplication.AddItem "未適用"
    cmbApplication.ListIndex = -1
    
    
End Sub

Private Sub cmdToroku_Click()
    '各項目で未入力または未選択がある場合、再入力を促す
    If cmbArea.Text = "" Then
        MsgBox "地域を入力してください"
        Exit Sub
    End If
    
    If cmbRegion.Text = "" Then
        MsgBox "地方を入力してください"
        Exit Sub
    End If
    
    If cmbFruit.Text = "" Then
        MsgBox "果物を入力してください"
        Exit Sub
    End If
    
    If cmbType.Text = "" Then
        MsgBox "種類を入力してください"
        Exit Sub
    End If

    If cmbSeason.Text = "" Then
        MsgBox "季節を入力してください"
        Exit Sub
    End If
       
    If cmbApplication.Text = "" Then
        MsgBox "適用or未適用を入力してください"
        Exit Sub
    End If
    
    If txtYear.Text = "" Then
        MsgBox "MYを入力してください"
        Exit Sub
    End If
    
    If txtStart.Text = "" Then
        MsgBox "startを入力してください"
        Exit Sub
    End If
    
    If txtEnd.Text = "" Then
        MsgBox "endを入力してください"
        Exit Sub
    End If
    
    '全ての項目が入っているとき、Sheet1のワークシートに対して最後の行の次の行にデータを格納していく
    With Worksheets("Sheet1")
        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
        .Cells(lastRow, 1).Value = cmbArea.Text
        .Cells(lastRow, 2).Value = cmbRegion.Text
        .Cells(lastRow, 3).Value = cmbFruit.Text
        .Cells(lastRow, 4).Value = cmbType.Text
        .Cells(lastRow, 5![イメージ説明](ea70f9b2ae82dbed878e51c1a1e58f9a.jpeg)e = cmbType.Text
        .Cells(lastRow, 6).Value = cmbApplication.Text
        .Cells(lastRow, 7).Value = txtYear.Text
        .Cells(lastRow, 8).Value = txtStart.Text
        .Cells(lastRow, 9).Value = txtEnd.Text
    End With
    
    '入力項目のリセット(項目のデフォルト設定も行える)
    cmbArea.Text = ""
    cmbRegion.Text = ""
    cmbFruit.Text = ""
    cmbType.Text = ""
    cmbSeason.Text = ""
    cmbApplication.Text = ""
    txtMy.Text = ""
    txtStart.Text = ""
    txtEnd.Text = ""
    
End Sub

試したこと

補足情報（FW/ツールのバージョンなど）

内容が複雑なのとVBAでできるかどうかの判断がつきませんが、ご回答をお願いいたします。

Answer 1

前提として、出力シートでは１年を１セルで表現するものと解釈しました。
17 18 21 ⇒ 2017年から４年分のデータを18列目～21列目(実際には20列目まで)で表示
20 21 24 ⇒ 2020年から４年分のデータを21列目～24列目(実際には23列目まで)で表示

---

上記のようにセル範囲にあわせて図形を作るのは比較的簡単です。

    Dim shp As Shape
    
    Dim dLeft As Double
    Dim dTop As Double
    Dim dWidth As Double
    Dim dHeight As Double
    
    Dim rng As Range
    Set rng = ActiveSheet.Range("A1:C1")   '例:A1:C1のセル範囲
    
    'セル範囲から位置・幅・高さを取得
    dLeft = rng.Left
    dTop  = rng.Top
    dWidth  = rng.Width
    dHeight = rng.Height
    
    '長方形シェイプを作成
    Set shp = ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, _
              Left:=dLeft, Top:=dTop, Width:=dWidth, Height:=dHeight)
    
    '作成したシェイプにテキスト入力
    shp.TextFrame.Characters.Text = "あああ"
    
    'shpを解放
    Set shp = Nothing

これを範囲指定して使いまわせるよう、関数化します。
以下、出力行・開始・終了・表示文字を引数として受け取れる関数にしたサンプルです。

Sub Sample()
    Call MakeShape(1, 18, 21, "秋")
    Call MakeShape(1, 21, 24, "春")
    Call MakeShape(2, 21, 24, "秋")
End Sub

Sub MakeShape(viRow as Integer, viSt As Integer, viEd As Integer, vsText As String)
    Dim shp As Shape
    
    Dim dLeft As Double
    Dim dTop As Double
    Dim dWidth As Double
    Dim dHeight As Double
    
    Dim rng As Range
    Set rng = ActiveSheet.Range(Activesheet.Cells(viRow, viSt), Activesheet.Cells(viRow, viEd - 1))   '例えばR1:U1のセル範囲
    
    'セル範囲から位置・幅・高さを取得
    dLeft = rng.Left
    dTop  = rng.Top
    dWidth  = rng.Width
    dHeight = rng.Height
    
    '長方形シェイプを作成
    Set shp = ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, _
              Left:=dLeft, Top:=dTop, Width:=dWidth, Height:=dHeight)
    
    '作成したシェイプにテキスト入力
    shp.TextFrame.Characters.Text = viText
    
End Sub

あくまでサンプルですので、引数は使いやすいように追加・変更していただければと思います。

---

上記のような、セル範囲を元にシェイプサイズを決める方法では、位置やサイズをシート側で調整することができます。

逆にシート側の影響を受けたくない場合や、セル範囲とは異なる座標・サイズで図形を作成したい場合は、Left/Top、Width/Heightをそれぞれ任意に算出すればよいです。

その他、書式の設定や塗りつぶしなどについては「VBA　シェイプの加工」のようなキーワードで検索すればいろいろ見つかると思います。

また、シェイプの追加～目的の見た目になるまでの操作を「マクロの記録」で記録し、作成されるコードを参考にするのもありだと思います。
がんばってみてください。

Comments

[Ryosuke_T]

ご回答ありがとうございます。
恐縮ですが2点ほど質問があります。
1点目は実際にVBAを実行したところ、長方形は表示されましたがテキストが入ってきませんでした。
2点目はサンプルの1～5行目のMakeShape関数を呼び出す部分ですが、見てみる限りデータを1行ごとに指定して呼び出しているように見えます。この部分をFor文などで入力データをすべてを読み込ませることはできるのでしょうか？(Call MakeShape(1,"セルH2","セルI2","セルE2"のような形です)
今回のサンプルだと3行あるので、For 1 To 3のようにMAXの値の分だけ図形を表示させることはできますでしょうか？

[jawa]

１点目については、サンプルコードに問題がありました。
文字列をセットする部分は
`shp.TextFrame.Characters.Text = viText`
のコードですが、関数の引数はvsTextですのでこの変数名を修正すれば表示されると思います。

２点目について、ループ処理にすることももちろん可能です。
というか、むしろそのための関数化です。
サンプルでは簡易に説明するため固定値で３回呼び出していますが、実際にはセルに値がある範囲でループ処理を行うことになります。

３行でループするなら
```
Dim iRowR As Integer '読込行
Dim iRowW As Integer '出力行

Dim iST As Integer
Dim iED As Integer
Dim sText As String

For iRowR = 1 To 3
iST = Cells(iRowRead, 8).Value 'H列よりStart取得
iED = Cells(iRowRead, 9).Value 'I列よりEnd取得
sText = Cells(iRowRead, 5).Value 'E列より表示文字取得

iRowW = iRowR '本来は出力行の判断が必要ですが、ここでは１行ずつ出力

'図形描画
Call MakeShape(iRowW, iST, iED, sText)
Next

```
のようなコードになりますが、実際はデータが存在する範囲でのループですよね。

出力位置にしても、同じグループの行位置に出力するよう判断が必要です。
加えて、色塗りなどの処理も必要になると思います。

まずはこのサンプルを参考に図形描画できるところまで作成し、その後足りない機能をひとつずつ追加していってみてください。
いろいろなことを一度に組み込むと、うまく動かないときに問題がどこにあるのかわかりにくくなってしまいますしね。

がんばってみてください。

[Ryosuke_T]

詳しいご説明ありがとうございます。
ひとつずつ機能を追加していこうと思います。
もう一つ質問ですが、機能を追加してセルに値がある範囲(最終行)を取得してその回数分だけループをさせて値を取得できるようにしました。そこで長方形の出力位置を考える際に、Excelの次の行と比較してある項目が異なった場合、次の行に長方形を出力するような処理を考えていますが、次の行と比較する方法はありますでしょうか？作成したコードを記載します。
考えているのは、次の行が地域・地方・果物・種類が同じであれば同じ行に長方形を出力し、種類が異なれば次の行に長方形を出力させるようにしたいと考えています。
```
Sub Sample()

Dim iRowR As Integer '読込行
Dim iRowW As Integer '出力行

Dim sAR As String '地域取得用
Dim sRE As String '地方取得用
Dim sFU As String '果物取得用
Dim sTY As String '種類取得用
Dim sSE As String '季節取得用
Dim sAP As String '適用or未適用取得用
Dim iYE As Integer 'Year取得用
Dim iST As Integer 'Start取得用
Dim iED As Integer 'End取得用
Dim sText As String '季節取得用

MaxRow = Range("A1").End(xlDown).Row '最終行を取得

For iRowR = 2 To MaxRow 'データ行は2行目から最終行までループ
sAR = Cells(iRowR, 1).Value 'A列より地域を取得
sRE = Cells(iRowR, 2).Value 'B列より地方を取得
sFU = Cells(iRowR, 3).Value 'C列より果物を取得
sTY = Cells(iRowR, 4).Value 'D列より種類を取得
sText = Cells(iRowR, 5).Value 'E列より表示文字取得
sAP = Cells(iRowR, 6).Value 'F列より適用or未適用を取得
iYE = Cells(iRowR, 7).Value 'G列よりYear取得
iST = Cells(iRowR, 8).Value 'H列よりStart取得
iED = Cells(iRowR, 9).Value 'I列よりEnd取得

iRowW = iRowR '本来は出力行の判断が必要ですが、ここでは１行ずつ出力
'図形描画
Call MakeShape(iRowW, iST, iED, sText)
Next

End Sub

[jawa]

「今から出力する行が、前回出力した行と異なっていたら改行」と考えればいいので、単純に１つ上の行から値を取得して比較すれば大丈夫です。
例えば
`sTY_Prev = Cells(iRowR -1, 4).Value 'D列より種類を取得（前行の値）`
といった具合に取得し、sTY_PrevとsTYが異なる場合に改行すればよいです。

ただし前行との比較で改行判定するということは、対象データがブレイク（改行）したいキー項目の順でソートされていることが前提条件となりますのでご注意ください。

前行と比較する以外の方法としては「出力の際に同じ項目の行を探す」という方法もあります。
流れとしては
①入力シートから１データ取得する
②出力済みのシートに取得データと一致する行がないか検索
③-a 見つかった場合、その行に図形だけ描画。
③-b 見つからなかった場合、新しい行にデータを出力。
といった感じになります。

参考までに。

[Ryosuke_T]

処理を追加してみました。
For文の中にsTY_Prev = Cells(iRowR - 1, 4) '種類を前の行から取得
を追加し、
iRowW = iRowR '2行目のデータはそのまま出力(セルの2行目から)
させ、
If文でsTY_PrevがsTYと異なる場合、そのセルのある行に出力させ、
それ以外は前の行に出力させるようにしました。
そこで2点ほど問題が見つかりました。
1つ目は種類が同じデータが2行以上あると、次の行で種類が異なった際に1行分空白となって次の行に長方形が表示されます。
1行目：(項目名が入っているため空白で問題なし)
2行目：■■
3行目：
4行目：　■
のような形です。原因は出力する部分がそのデータのある「行」を参照しているためだと思われますが、
次の行に出力する方法はありますでしょうか？

2つ目は、種類が同じデータが3行以上あると、3行目以降の長方形が1行ずつ下にずれて表示されてしまいます。
原因は、長方形を作る部分で MakeShape(iRowW - 1, iST, iED, sText)で
前の行に出力するというように書いているからだと思います。
種類が同じ場合は、同じ位置に長方形を出力する方法はありますでしょうか？
質問ばかりで申し訳ございませんが、教えていただければ幸いです。
コードを記載します。

Sub Sample()

Dim iRowR As Integer '読込行
Dim iRowW As Integer '出力行

Dim sAR As String '地域取得用
Dim sRE As String '地方取得用
Dim sFU As String '果物取得用
Dim sTY As String '種類取得用
Dim sSE As String '季節取得用
Dim sAP As String '適用or未適用取得用
Dim iYE As Integer 'Year取得用
Dim iST As Integer 'Start取得用
Dim iED As Integer 'End取得用
Dim sText As String '季節取得用

MaxRow = Range("A1").End(xlDown).Row '最終行を取得

For iRowR = 2 To MaxRow 'データ行は2行目から最終行までループ
sAR = Cells(iRowR, 1).Value 'A列より地域を取得
sRE = Cells(iRowR, 2).Value 'B列より地方を取得
sFU = Cells(iRowR, 3).Value 'C列より果物を取得
sTY = Cells(iRowR, 4).Value 'D列より種類を取得
sTY_Prev = Cells(iRowR - 1, 4) '種類を前の行から取得
sText = Cells(iRowR, 5).Value 'E列より表示文字取得
sAP = Cells(iRowR, 6).Value 'F列より適用or未適用を取得
iYE = Cells(iRowR, 7).Value 'G列よりYear取得
iST = Cells(iRowR, 8).Value 'H列よりStart取得
iED = Cells(iRowR, 9).Value 'I列よりEnd取得

iRowW = iRowR '2行目のデータはそのまま出力

If sTY_Prev <> sTY Then '前の行と今回の行の種類が異なる場合

iRowW = iRowR
'図形描画
Call MakeShape(iRowW, iST, iED, sText)

Else
Call MakeShape(iRowW - 1, iST, iED, sText)
End If
Next

End Sub

[jawa]

結論から言うと、原因は２点とも同じで「読込行に引きずられて出力位置が進んでしまっている」ところに問題があります。

ループ内で各変数の値がどのように移り変わっていくか、机上でもデバッグでもいいのでループ３週目くらいまで追ってみるとその意味が分かるかと思います。

---
読込行(iRowR)は「1行読んだら次の行」という具合に毎回必ず進めていきますよね。
これをコード内で行っているのがFor～Next文です。

これに対して出力行(iRowW)は「前行と違ったら次の行」という具合に条件付きで行が進んでいきます。
しかし提示したサンプルではそこまでは実装しておらず、読込行と一緒に毎回次の行に進めていました。
コード上では`iRowW = iRowR`という部分がそれでした。

今回、出力行の改行判定を追加したいのですから変更するのはこの部分です。

「今から出力する行が、前回出力した行と異なっていたら改行」という考え方という話をしました。
それをそのままコードにすると
```
If sTY_Prev <> sTY Then '前の行と今回の行の種類が異なる場合
iRowW = iRowW + 1 '出力行を１つ進める
End If

'図形描画
Call MakeShape(iRowW, iST, iED, sText)
```
となります。

読込シートから読み込む行番号と、出力シートに書き出す行番号をそれぞれ別々に管理して進めていくので混乱しそうですが、よく使われる技法ですので何本も作っていれば慣れてくると思います。
がんばってください。

[Ryosuke_T]

Ifで条件を追加してみました。
iRowR=2ならそのまま出力させるような分岐、教えていただいた前の行と今回の行の種類が異なる場合、
前の行と今回の行の種類が同じ場合の分岐を加えてみました。
ネックになっているのが前の行と今回の行の種類が同じ場合の処理で、
どのようにして種類が同じ行に長方形を出力させればいいかがわかりません。
出力行iRowWの値を種類が変化した部分にすれば解決しそうではあると考えましたが、
プログラム上で指定させる方法がわかりませんでした・・・
```
ElseIf sTY_Prev = sTY Then '前の行と今回の行の種類が同じ場合
iRowW = iRowR
Call MakeShape(iRowW, iST, iED, sText)
```
iRowW=iRowRを変えるというのは前回おっしゃられていました、どのように変えるのがベストでしょうか？教えてください。

```
MaxRow = Range("A1").End(xlDown).Row '最終行を取得

For iRowR = 2 To MaxRow 'データ行は2行目から最終行までループ
sAR = Cells(iRowR, 1).Value 'A列より地域を取得
sRE = Cells(iRowR, 2).Value 'B列より地方を取得
sFU = Cells(iRowR, 3).Value 'C列より果物を取得
sTY = Cells(iRowR, 4).Value 'D列より種類を取得
sTY_Prev = Cells(iRowR - 1, 4) '種類を前の行から取得
sText = Cells(iRowR, 5).Value 'E列より表示文字取得
sAP = Cells(iRowR, 6).Value 'F列より適用or未適用を取得
iYE = Cells(iRowR, 7).Value 'G列よりYear取得
iST = Cells(iRowR, 8).Value 'H列よりStart取得
iED = Cells(iRowR, 9).Value 'I列よりEnd取得

If iRowR = 2 Then
iRowW = iRowR '2行目のデータはそのまま出力
Call MakeShape(iRowW, iST, iED, sText)

ElseIf sTY_Prev <> sTY Then '前の行と今回の行の種類が異なる場合

iRowW = iRowW + 1 '次の行に出力
Call MakeShape(iRowW, iST, iED, sText)

ElseIf sTY_Prev = sTY Then '前の行と今回の行の種類が同じ場合
iRowW = iRowR
Call MakeShape(iRowW, iST, iED, sText)
End If
Next

End Sub
```

[jawa]

だいぶおしいところまできていますね。

前回読み込んだ行と今回読み込んだ行の「種類」が同じ場合の出力処理ですが、この場合は前回出力した行と同じ行に出力したいはずです。
つまり、出力行は（前回の出力行から）変更せずに図形描画したいということです。

```
（～中略～）

ElseIf sTY_Prev = sTY Then '前の行と今回の行の種類が同じ場合
'iRowW = iRowR '
Call MakeShape(iRowW, iST, iED, sText)
End If
```
としてみてください。
そろそろ期待する動作に近づいたのではないでしょうか？
あとは「種類」だけでなく他のブレイク項目も判定に加えてあげればよさそうです。

あとひといき、がんばってください。

[Ryosuke_T]

ありがとうございます。
かなり目的に沿った動作ができるようになりました。
最後に一点だけ教えてください。
現在、StartとEndの値は「18」や「21」など整数で値を持っているため、長方形を出力しやすいと思われます。
実際に扱うデータには小数点のデータがあります(18.5など)
これに伴って、長方形を出力する位置を半分だけ右にずらす方法はあるのでしょうか？
Start=18、End=21はRセルUセルですが、Start=18.5、Endセル=21.5のときはRセルの半分からUセルの半分までのように出力することは可能でしょうか？

[jawa]

１セルの幅はCell.Widthで取得できます。
STやEDに端数がある場合、この１セル分の幅に端数を掛けて、その分だけ座標をずれせばよいと思います。

例えばセル幅が20だったとして、STが10.5の場合、X座標は10列目のLeftに10列目のWidth*0.5した位置とすれば期待される位置になると思います。

この計算を行うためには、`10.5`を整数部`10`と少数部`0.5`に分ける必要があります。
方法はいくつかありますが、まず整数部である`10`を取得し、元の`10.5`からその`10`を引いた残りが小数部`0.5`という求め方での実装例をご紹介します。

'--↓修正コード　引数の型と名前を変更
Sub MakeShape(viRow as Integer, vdSt As Double, vdEd As Double, vsText As String)
'--↑修正コード　引数の型と名前を変更
Dim shp As Shape

Dim dLeft As Double
Dim dTop As Double
Dim dWidth As Double
Dim dHeight As Double

'--↓追加コード
Dim iST As Integer '始点の整数部
Dim iED As Integer '終点の整数部
Dim dST_SHOSU As Double '始点の小数部
Dim dED_SHOSU As Double '終点の小数部

'始点・終点の整数部・小数部
iST = Int(vdST) '始点の整数部： 引数vdSTより少数切捨て　で取得
dST_SHOSU = vdST - iST '終点の整数部： 引数vdST － 始点整数部　で取得
iED = Int(vdED) '始点の小数部： 引数vdEDより少数切捨て　で取得
dED_SHOSU = vdED - iED '終点の小数部： 引数vdED － 終点整数部　で取得

Dim dCellWidth As Double '先頭セルの幅
dCellWidth = Activesheet.Cells(viRow, iSt).Width '先頭セルの幅を取得
'--↑追加コード

Dim rng As Range
'--↓修正コード
'Set rng = ActiveSheet.Range(Activesheet.Cells(viRow, viSt), Activesheet.Cells(viRow, viEd - 1)) '例えばR1:U1のセル範囲
Set rng = ActiveSheet.Range(Activesheet.Cells(viRow, iSt), Activesheet.Cells(viRow, iEd - 1)) '例えばR1:U1のセル範囲
'--↑修正コード

'セル範囲から位置・幅・高さを取得

dLeft = rng.Left
dTop = rng.Top
dWidth = rng.Width
dHeight = rng.Height

'--↓追加コード
dLeft = dLeft + (dCellWidth * dST_SHOSU) 'X座標は始点調整分だけ右にずらす。
dWidth = rng.Width - (dCellWidth * dST_SHOSU) + (dCellWidth * dED_SHOSU) '幅は始点調整分を短くする。また終点調整分を長くする。
'--↑追加コード

'長方形シェイプを作成
Set shp = ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=dLeft, Top:=dTop, Width:=dWidth, Height:=dHeight)

'作成したシェイプにテキスト入力
shp.TextFrame.Characters.Text = viText

End Sub
```

机上で変更したコードなのでそのまま動くかはあやしいですが、手法としてはこんな感じです。

注意点としては、Integer型は整数しか扱えないため、少数を扱う場合はDouble型の変数にセル値などを格納する必要があるというあたりでしょうか。
上記コードで引数はDouble型にしていますが、当然呼び出し側も少数が扱えなければいけませんのでご注意ください。

---
今回は描画座標をずらす方法をご紹介しました。

もともとセルの位置に依存した描画方法のご紹介という観点でアドバイスをしていましたので、ちょっと面倒な調整が必要になっています。
今回の方法とは別になりますが、端数が0.5単位で発生するのなら列数を倍に増やすことでも対応できます。
簡単な例で説明すると、ST=10なら20列目、ST=10.5なら21列目から描画、という具合にSTを2倍したセルから描画するイメージになります。

参考になれば幸いです。

Answer 2

まず、シェイプで長方形を作成して長さを調整する、
という方式は素人には調整が難しいのでやめといた方がいいかと。

単純に各年を４列で区切り、該当する季節をVBAで塗る、
という方法が分かりやすいし処理しやすいでしょう。

各行で白色で太い横罫線を引いておけば、
色の見分けにくさも軽減できるかと。

Answer 3

質問者さんの言われる「マップ」が何を指すのかいまいち理解できていませんが、指定された値から長方形の寸法を決める、というのであれば、AddShapeについて調べられると良いと思います。

長方形にテキストも入れたいのであれば、テキストボックスを作成するAddTextboxが目的にかなっているのではないでしょうか。