一度Excelのセルに打ったものを一気に図形オブジェクトに変換したい時用マクロ。
例）これを
↓
----------------------------------------------------------------
Private Sub MakeObject()
Dim WB As Workbook
Set WB = ThisWorkbook
Dim WS1 As Worksheet
Set WS1 = WB.ActiveSheet
'--------------------------------------------------------
'実行速度向上のため画面更新と自動計算を停止
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'-----------------------------------------------------------
'現在選択しているセルの取得
Dim intStartGyo As Integer: intStartGyo = Selection.Row
Dim intLastGyo As Integer: intLastGyo = Selection.Row + Selection.Rows.Count - 1
Dim intStartRow As Integer: intStartRow = Selection.Column
Dim intLastRow As Integer: intLastRow = Selection.Column + Selection.Columns.Count - 1
'※初期置
Dim Rng As Range
Set Rng = WS1.Cells(intStartGyo, intStartRow)
Dim lWidth As Long: lWidth = 100 'オブジェクトのサイズ
Dim lHeight As Long: lHeight = 20 'オブジェクトのサイズ
lLeft = Rng.Left + 10
For i = intStartGyo To intLastGyo
lTop = Rng.Top
For j = intStartRow To intLastRow
'If Len(WS1.cells(i, j).Text) > 0 And WS1.cells(i, j).Text > 0 Then '空欄なら作らない
'図形の作成---------------------------------------
Dim myShape1 As Shape
Dim strText As String
strText = WS1.Cells(i, j).Text
Set myShape1 = WS1.Shapes.AddShape( _
Type:=msoShapeRectangle, _
Left:=lLeft, _
Top:=lTop, _
Width:=lWidth, _
Height:=lHeight)
With myShape1
.Fill.Visible = msoTrue
.Fill.Solid
.TextFrame.Characters.Text = strText
.TextFrame.HorizontalAlignment = xlCenter
End With
'-------------------------------------------------------
'追加位置を下へずらす
lTop = lTop + lHeight + 5
'End If
Next
'追加位置を右へずらす
lLeft = lLeft + lWidth + 5
Next
'実行速度向上のため画面更新と自動計算を再開---------------
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
'-----------------------------------------------------------
End Sub
