フローや機能要件を作成するときに
一度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
