Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Option Explicit
'セルを全て図形に変換する
Sub main()
Dim row As Long
Dim col As Long
Dim maxrow As Long
Dim maxcol As Long
'対象範囲指定
maxrow = 1000
maxcol = 1000
For row = 1 To maxrow
For col = 1 To maxcol
'セル内に文字が入っていれば、オートシェイプに変換
If Cells(row, col).Value <> "" Then
convertCellToShape (Cells(row, col))
End If
Next col
Next row
End Sub
Sub convertCellToShape(cell)
Dim w As Integer
Dim h As Integer
Dim txt As String
Dim font_color As Long
Dim border_color As Long
Dim back_color As Long
'セル情報取得
w = cell.Width
h = cell.Height
txt = cell.Value
font_color = cell.Font.Color
border_color = cell.Borders.Color
back_color = cell.Interior.Color
'図形生成
With ActiveSheet.Shapes.AddShape _
(msoShapeRectangle, cell.Left, cell.Top, w, h)
.TextFrame.Characters.Text = txt
.TextFrame.Characters.Font.Color = font_color
.TextFrame.HorizontalAlignment = xlHAlignCenter
.TextFrame.VerticalAlignment = xlVAlignCenter
.Line.ForeColor.RGB = border_color
.Fill.ForeColor.RGB = back_color
End With
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment