複数テキストボックス挿入時のテキストを変数として入力したい。

Question

実現したいこと

ガントチャートを作成しており、カレンダーの日付に合わせたサイズのテキストボックスを複数挿入するところまではうまくいったのですが、各テキストボックスの中のテキスト(文字)を変数として設定し、それぞれに挿入することがうまくいかないのでこれを実現したいと考えています。アドバイスいただけますと幸いです。

発生している問題・分からないこと

With .TextFrame
.Characters.Text = x
のｘに変数として設定し、一応認識しているようですが、挿入した複数のテキストボックスすべてに最下行の文字列が挿入されております。

該当のソースコード

Sub テキストボックス()
   Application.ScreenUpdating = False
   Application.Cursor = xlWait
   Application.EnableEvents = False
   Application.DisplayAlerts = False
   Application.Calculation = xlCalculationManual
Dim sh1 As Worksheet
 Set sh1 = Worksheets("Gantt")
Dim b, S, E, i

b = sh1.Range("Q4")
For i = 7 To sh1.Cells(Rows.Count, "M").End(xlUp).row
If Cells(i, "M") <> "" And Cells(i, "N") <> "" Then
Set S = sh1.Cells(i, "Q").Offset(0, DateDiff("d", b, Cells(i, "M")))
Set E = sh1.Cells(i, "Q").Offset(0, DateDiff("d", b, Cells(i, "N")))

Call 挿入(S, E)
End If
Next
    Application.StatusBar = False
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.Cursor = xlDefault
    Application.ScreenUpdating = True
End Sub

Sub 挿入(S, E)
   Application.ScreenUpdating = False
   Application.Cursor = xlWait
   Application.EnableEvents = False
   Application.DisplayAlerts = False
   Application.Calculation = xlCalculationManual
 
 Set sh1 = Worksheets("Gantt")
Dim i As Long
 For i = 7 To sh1.Cells(Rows.Count, "B").End(xlUp).row
  x = sh1.Cells(i, "B").value
With sh1.Shapes.AddTextbox(msoTextOrientationHorizontal, S.Left, S.Top, (E.Left + E.Width) - S.Left, E.Height)
With .TextFrame
      .Characters.Text = x
      .Characters.Font.Color = RGB(0, 0, 0)
      .HorizontalAlignment = xlHAlignCenter
      .VerticalAlignment = xlVAlignCenter
    End With
   With .Fill
        .ForeColor.ObjectThemeColor = msoThemeColorAccent1
        .ForeColor.Brightness = 0.800000011
  End With
End With
Next i
    Application.StatusBar = False
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.Cursor = xlDefault
    Application.ScreenUpdating = True
End Sub

試したこと・調べたこと

• teratailやGoogle等で検索した
• ソースコードを自分なりに変更した
• 知人に聞いた
• その他

上記の詳細・結果

x = sh1.Cells(i, "B").valueかｘの書く位置が悪いのではないかといろいろ変更しましたがうまくいきません。

補足

特になし

Comments

[sk.exe]

> Set sh1 = Worksheets("Gantt")

ワークシート[Gantt]の構造、およびそれを前提とした自動処理の仕様が不明瞭です。

> b = sh1.Range("Q4")

・Q4 セルは何の値を入力するためのセルか。

> For i = 7 To sh1.Cells(Rows.Count, "M").End(xlUp).row

> Set S = sh1.Cells(i, "Q").Offset(0, DateDiff("d", b, Cells(i, "M")))
> Set E = sh1.Cells(i, "Q").Offset(0, DateDiff("d", b, Cells(i, "N")))

> For i = 7 To sh1.Cells(Rows.Count, "B").End(xlUp).row

・7行目以降の B 列、M 列、N 列および Q 列のセルのそれぞれの役割は何なのか。

> 各テキストボックスの中のテキスト(文字)を変数として設定し、それぞれに挿入する

・作成したテキストボックスに代入したいのはどんな文字列なのか。
　また、何のために変数を使用するのか。

とりあえず、以上の点について具体的に明記されることをお奨めします。

[hajihaji]

言葉足らずですみません。

> Set sh1 = Worksheets("Gantt")

ワークシート[Gantt]の構造、およびそれを前提とした自動処理の仕様が不明瞭です。

> b = sh1.Range("Q4")

・Q4 セルは何の値を入力するためのセルか。
A:　Q4から横軸に日別のカレンダーを配置しています。
> For i = 7 To sh1.Cells(Rows.Count, "M").End(xlUp).row

> Set S = sh1.Cells(i, "Q").Offset(0, DateDiff("d", b, Cells(i, "M")))
> Set E = sh1.Cells(i, "Q").Offset(0, DateDiff("d", b, Cells(i, "N")))

> For i = 7 To sh1.Cells(Rows.Count, "B").End(xlUp).row

・7行目以降の B 列、M 列、N 列および Q 列のセルのそれぞれの役割は何なのか。
A:　B＝名称　M＝日付　N＝日付
> 各テキストボックスの中のテキスト(文字)を変数として設定し、それぞれに挿入する

・作成したテキストボックスに代入したいのはどんな文字列なのか。
　また、何のために変数を使用するのか。
A：　挿入したいのは文字列です。変数を使用したいのは挿入箇所(位置)に対応した文字列がそれぞれ異なるためです。
とりあえず、以上の点について具体的に明記されることをお奨めします。

Answer 1

挿入プロシージャ内でテキストボックス挿入を行数分繰り返しているので、前のテキストボックスの上に後のテキストボックスが重ねて配置されてます。ですので、最後の文字列のテキストボックスが一番前面にくるのでそれが表示されているように見えます。一番上のテキストボックスを削除するその下にテキストボックスがあるのが分かると思います。

挿入プロシージャ内のループは必要ないです。挿入するテキストは開始セルの行のB列(sh1.Cells(S.Row, "B").Value)にすればいいでしょう。

Sub 挿入(S, E)
'    ↓デバッグ中はコメントアウトしておく。動作が確認出来たら、コメントを外す。
'    Application.ScreenUpdating = False
'    Application.Cursor = xlWait
'    Application.EnableEvents = False
'    Application.DisplayAlerts = False
'    Application.Calculation = xlCalculationManual

    Dim sh1 As Worksheet
    Set sh1 = Worksheets("Gantt")
    Dim x
    x = sh1.Cells(S.Row, "B").Value
    With sh1.Shapes.AddTextbox(msoTextOrientationHorizontal, S.Left, S.Top, (E.Left + E.Width) - S.Left, E.Height)
        With .TextFrame
            .Characters.Text = x
            .Characters.Font.Color = rgb(0, 0, 0)
            .HorizontalAlignment = xlHAlignCenter
            .VerticalAlignment = xlVAlignCenter
        End With
        With .Fill
            .ForeColor.ObjectThemeColor = msoThemeColorAccent1
            .ForeColor.Brightness = 0.800000011
        End With
    End With
    '    Application.StatusBar = False
    '    Application.Calculation = xlCalculationAutomatic
    '    Application.DisplayAlerts = True
    '    Application.EnableEvents = True
    '    Application.Cursor = xlDefault
    '    Application.ScreenUpdating = True
End Sub

Answer 2

Q4から横軸に日別のカレンダーを配置

B＝名称　M＝日付　N＝日付

Sub CreateGanttBars()
On Error GoTo Err_CreateGanttBars
    
    Dim wsTarget As Worksheet
    
    Set wsTarget = ThisWorkbook.Worksheets("Gantt")
    
    Dim lngDateHeaderRow As Long
    Dim lngFirstWorkRow As Long
    Dim lngLastWorkRow As Long
    Dim rngFirstDate As Range
    Dim rngLastDate As Range
    
    With wsTarget
        
        lngFirstWorkRow = 7
        lngLastWorkRow = .Cells(.Rows.Count, "M").End(xlUp).Row
        
        If lngFirstWorkRow > lngLastWorkRow Then
            MsgBox "作業開始日が入力されているタスクがありません。", vbInformation, "終了"
            Set wsTarget = Nothing
            Exit Sub
        End If
        
        lngDateHeaderRow = 4
        Set rngFirstDate = .Cells(lngDateHeaderRow, "Q")
        '最後の日付セルを固定で指定する場合は適宜書き換えること
        Set rngLastDate = .Cells(lngDateHeaderRow, .Columns.Count).End(xlToLeft)
    
        If rngFirstDate.Column > rngLastDate.Column Then
            MsgBox "工程期間が設定されていません。", vbInformation, "終了"
            Set rngFirstDate = Nothing
            Set rngLastDate = Nothing
            Set wsTarget = Nothing
            Exit Sub
        End If
        
        .Select
    
    End With
    
    If IsDate(rngFirstDate.Value) = False Then
        MsgBox "工程管理期間の開始日を正しく入力してください。", vbExclamation, "エラー"
        rngFirstDate.Select
        Set rngFirstDate = Nothing
        Set rngLastDate = Nothing
        Set wsTarget = Nothing
        Exit Sub
    End If
    
    If IsDate(rngLastDate.Value) = False Then
        MsgBox "工程管理期間の終了日を正しく入力してください。", vbExclamation, "エラー"
        rngLastDate.Select
        Set rngFirstDate = Nothing
        Set rngLastDate = Nothing
        Set wsTarget = Nothing
        Exit Sub
    End If
    
    Dim lngWorkRow As Long
    Dim strTaskName As String
    Dim rngStartWorkDate As Range
    Dim rngEndWorkDate As Range
    Dim lngStartOffset As Long
    Dim lngEndOffset As Long
    Dim rngStartDraw As Range
    Dim rngEndDraw As Range
    Dim rngDrawArea As Range
    Dim shpGantBar As Shape
    
    With Application
        .StatusBar = "ガントバーの作成処理中です..."
        .ScreenUpdating = False
        .Cursor = xlWait
        .EnableEvents = False
        .DisplayAlerts = False
        .Calculation = xlCalculationManual
    End With
    
'    'シート上の全ての図形を削除する場合は有効化
'    wsTarget.Shapes.SelectAll
'    Selection.Delete
    
    For lngWorkRow = lngFirstWorkRow To lngLastWorkRow
        
        strTaskName = wsTarget.Cells(lngWorkRow, "B").Value
        Set rngStartWorkDate = wsTarget.Cells(lngWorkRow, "M")
        Set rngEndWorkDate = wsTarget.Cells(lngWorkRow, "N")
        
        If IsDate(rngStartWorkDate.Value) Then
            If rngStartWorkDate.Value < rngFirstDate.Value Then
                Set rngStartDraw = wsTarget.Cells(lngWorkRow, rngFirstDate.Column)
            ElseIf rngStartWorkDate.Value > rngLastDate.Value Then
                Set rngStartDraw = Nothing
            Else
                lngStartOffset = DateDiff("d", rngFirstDate.Value, rngStartWorkDate.Value)
                Set rngStartDraw = wsTarget.Cells(lngWorkRow, rngFirstDate.Column) _
                                           .Offset(0, lngStartOffset)
            End If
        Else
            Set rngStartDraw = Nothing
        End If
        
        If IsDate(rngEndWorkDate.Value) Then
            If rngEndWorkDate.Value < rngFirstDate.Value Then
                Set rngEndDraw = Nothing
            ElseIf rngEndWorkDate.Value > rngLastDate.Value Then
                Set rngEndDraw = wsTarget.Cells(lngWorkRow, rngLastDate.Column)
            Else
                lngEndOffset = DateDiff("d", rngFirstDate.Value, rngEndWorkDate.Value)
                Set rngEndDraw = wsTarget.Cells(lngWorkRow, rngFirstDate.Column) _
                                         .Offset(0, lngEndOffset)
            End If
        Else
            Set rngEndDraw = Nothing
        End If
        
        If (Not rngStartDraw Is Nothing) And (Not rngEndDraw Is Nothing) Then
            If rngStartWorkDate.Value > rngEndWorkDate.Value Then
                Set rngDrawArea = Nothing
            Else
                Set rngDrawArea = wsTarget.Range(rngStartDraw, rngEndDraw)
            End If
        End If
        
        If Not rngDrawArea Is Nothing Then
            
            Debug.Print "工程名: " & strTaskName
            Debug.Print vbTab & "作業開始日: " & rngStartWorkDate.Value
            Debug.Print vbTab & "作業終了日: " & rngEndWorkDate.Value
            Debug.Print vbTab & "描画領域: " & rngDrawArea.Address
            
            Set shpGantBar = wsTarget.Shapes.AddTextbox(msoTextOrientationHorizontal, _
                                                        rngDrawArea.Left, _
                                                        rngDrawArea.Top, _
                                                        rngDrawArea.Width, _
                                                        rngDrawArea.Height)
            With shpGantBar
                With .TextFrame
                    .Characters.Text = strTaskName
                    .Characters.Font.Color = RGB(0, 0, 0)
                    .HorizontalAlignment = xlHAlignCenter
                    .VerticalAlignment = xlVAlignCenter
                End With
                With .Fill
                  .ForeColor.ObjectThemeColor = msoThemeColorAccent1
                  .ForeColor.Brightness = 0.800000011
                End With
            End With
            
            Set shpGantBar = Nothing
        End If
        
        Set rngDrawArea = Nothing
        Set rngStartDraw = Nothing
        Set rngEndDraw = Nothing
        
        Set rngStartWorkDate = Nothing
        Set rngEndWorkDate = Nothing
    Next
    
Exit_CreateGanttBars:
    
    Set rngFirstDate = Nothing
    Set rngLastDate = Nothing
    Set wsTarget = Nothing
    
    With Application
        .StatusBar = False
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
        .EnableEvents = True
        .Cursor = xlDefault
        .ScreenUpdating = True
    End With
    
    Exit Sub
    
Err_CreateGanttBars:

    Dim strErrTitle As String
    Dim strErrMsg As String
    
    strErrTitle = "実行時エラー (CreateGanttBars)"
    strErrMsg = Err.Number & ": " & Err.Description
    
    Debug.Print strErrTitle
    Debug.Print strErrMsg
    
    MsgBox strErrMsg, vbCritical, strErrTitle
    
    Resume Exit_CreateGanttBars
End Sub