FC2ブログ

シェイプマクロを極める。

2017–06–20 (Tue) 09:54
私の中で一番嫌いかもしれない、オートシェイプのマクロを作成いたしましたので紹介します。
まぁ・・・・・・使いやすいかな?と言うところです。
自分の中では使いやすいエクセルマクロと言うところですね~

Sub 名前を付ける()
Dim buf As String
buf = InputBox("名前を入力してください")
Selection.ShapeRange.Name = buf
End Sub
Sub シェイプ削除()
Dim sp As Shape
Dim cell As Range
Set cell = Application.InputBox(Prompt:="シェイプ名が入力された式を選択してください", Type:=8)
CKRow = 1
CRow = cell.Rows.count
CCol = Range(cell.Address(1)).Column
sakujo = 0
kazu = 0
Do Until kazu = ActiveSheet.Shapes.count
For CKRow = CKRow To CRow
For Each sp In ActiveSheet.Shapes
If cell(CKRow, 1).Value = sp.Name Then
With sp
.Fill.ForeColor.RGB = RGB(255, 0, 0)
End With
End If
Next
Next
CKRow = 1
kazu = kazu + 1
If kazu > ActiveSheet.Shapes.count Then
kazu = 0
End If
Loop

For Each sp In ActiveSheet.Shapes
If sp.Fill.ForeColor.RGB <> RGB(255, 0, 0) Then
sp.Delete
End If
Next

For Each sp In ActiveSheet.Shapes
sp.Fill.Visible = msoFalse
Next
End Sub


Sub シェイプ名前抽出()

Dim Spname As Variant
Set cell = Application.InputBox(Prompt:="シェイプ名を入力を開始するセルを選択してください", Type:=8)
Application.ScreenUpdating = False
CKRow = Range(cell.Address).Row
CCol = Range(cell.Address).Column
i = 0
CRow = CKRow
For Each sp In ActiveSheet.Shapes
If sp.Type = msoGroup Then
sp.Ungroup
End If

Next
ReDim Spname(ActiveSheet.Shapes.count, 0)

For Each sp In ActiveSheet.Shapes
Spname(i, 0) = sp.Name
i = i + 1
CRow = CRow + 1
Next

Range(Cells(CKRow, CCol), Cells(CRow, CCol)) = Spname
Application.ScreenUpdating = True
End Sub

スポンサーサイト



« 選択したセルに同じ数を追加するマクロ | HOME |  三ヶ月計算 »

コメント

コメントの投稿

 
管理者にだけ表示

 | HOME | 

プロフィール

はる

Author:はる
FC2ブログへようこそ!

最新記事

最新コメント

フリーエリア

月別アーカイブ

カテゴリ

ブロとも申請フォーム

検索フォーム

RSSリンクの表示

リンク