正式版

Sub テキストボックス作成()
Dim originalShape As shape
Dim newShape As shape
Dim i As Integer, j As Integer
Dim horizontalSpacing As Single
Dim verticalSpacing As Single
Dim columns As Integer
Dim shapeCounts As Variant
Dim currentShape As Integer
Dim shapeIndex As Integer
Dim currentRow As Integer
Dim currentColumn As Integer

' 列の数を入力するためのInputBoxを表示
columns = InputBox("何列にしますか？（区切る数より多く）", "列の設定", 3)
' 作る個数をスペースで区切って入力するためのInputBoxを表示
shapeCounts = Split(InputBox("作る個数をスペースで区切って入力してください（例：5 3 3 3 3 3）", "個数の設定", "5 3 3 3 3 3"))

' 新しいテキストボックスを作成
Set originalShape = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 100, 4.52 * 28.35, 1.71 * 28.35) ' cmをポイントに変換
With originalShape.TextFrame.Characters.Font
    .Name = "Meiryo UI"
    .Size = 11 ' 任意の初期サイズ
End With
' 塗りつぶしなし、線の色は黒、線の太さは0.75に設定
With originalShape.line
    .ForeColor.RGB = RGB(0, 0, 0)
    .Weight = 0.75
End With
originalShape.Fill.Transparency = 1

' 間隔の設定
horizontalSpacing = 10
verticalSpacing = 20

' 指定された個数で複製
currentShape = 1
currentRow = 0
currentColumn = 0
For shapeIndex = 0 To UBound(shapeCounts)
    For i = 1 To CInt(shapeCounts(shapeIndex))
        If currentShape > 1 Then
            ' 複製を作成
            Set newShape = originalShape.Duplicate
            ' 新しい位置を設定
            newShape.Left = originalShape.Left + (originalShape.Width + horizontalSpacing) * currentColumn
            newShape.Top = originalShape.Top + (originalShape.Height + verticalSpacing) * currentRow
            ' デフォルトのフォントを設定
            With newShape.TextFrame.Characters.Font
                .Name = "Meiryo UI"
                .Size = 11 ' 任意の初期サイズ
            End With
            ' 塗りつぶしなし、線の色は黒、線の太さは0.75に設定
            With newShape.line
                .ForeColor.RGB = RGB(0, 0, 0)
                .Weight = 0.75
            End With
            newShape.Fill.Transparency = 1
        End If
        currentShape = currentShape + 1
        currentColumn = currentColumn + 1
        If currentColumn >= columns Then
            currentColumn = 0
            currentRow = currentRow + 1
        End If
    Next i
    currentRow = currentRow + 1 ' 各塊の間に1行空ける
    currentColumn = 0
Next shapeIndex

End Sub

Sub テキストボックスに書き込み()
Dim shp As shape
Dim i As Integer
Dim lastRow As Long
Dim firstLine As String
Dim secondLine As String
Dim pos As Long
Dim ws As Worksheet
Dim activeWs As Worksheet

' シート「WORK」を設定
Set ws = Worksheets("WORK")
' アクティブシートを設定
Set activeWs = ActiveSheet

' シート「WORK」内の最後の行を取得
lastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).row

' 空のテキストボックスに値を埋める
i = 1
For Each shp In activeWs.Shapes
    If shp.Type = msoTextBox Then
        If shp.TextFrame.Characters.text = "" Then
            If i <= lastRow Then
                ' 1行目と2行目の内容を設定
                firstLine = ws.Cells(i, "E").Value
                secondLine = ws.Cells(i, "F").Value
                shp.TextFrame.Characters.text = firstLine & vbCrLf & secondLine

                ' 1行目のフォント設定
                With shp.TextFrame.Characters(1, Len(firstLine)).Font
                    .Name = "Meiryo UI"
                    .Size = 11
                End With

                ' 2行目のフォント設定
                pos = Len(firstLine) + 2 ' 2行目の開始位置を設定
                With shp.TextFrame.Characters(pos, Len(secondLine)).Font
                    .Name = "Meiryo UI"
                    .Size = 8
                End With

                ' テキストを中央揃えに設定
                shp.TextFrame.HorizontalAlignment = xlHAlignCenter

                i = i + 1
            Else
                Exit For
            End If
        End If
    End If
Next shp

End Sub