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

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

スポンサーサイト

選択したセルに同じ数を追加するマクロ

2017–06–20 (Tue) 00:24
エクセルマクロはエクセルなのに何故かセルにアクセスするともの凄く遅くなります。
その為作成したマクロになります。
これは選択したセルに数を足すマクロです。
需要があるかは分かりませんが……。

Sub 配列に代入して計算するマクロ
nyuryoku = Selection.Address
Dim Sets As Variant
Dim SetsU As Long
Sets = Range(nyuryoku)
SetsU = UBound(Sets)
SetuL = UBound(Sets, 2)
dum Kazu as Long
Kazu = InputBox("足す数を入力してください")
For i = 1 To SetsU

For j = 1 To SetuL
On Error Resume Next

Sets(i, j) = Sets(i, j) + Kazu

選択したオートシェイプに名前を付ける

2017–06–19 (Mon) 23:50
選択弑オートシェイプに名前を付けるマクロです。
これを使用することにより、エクセル内のオートシェイプを整理する事ができます。

Sub 名前を付ける
Dim buf As String
buf = InputBox("名前を入力してください")
Selection.ShapeRange = buf
End Sub

削除マクロなどと組み合わせることによりさらに使いやすくなると思います。

2017–06–15 (Thu) 17:03
Sub del()
Application.ScreenUpdating = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = True
Application.ScreenUpdating = True
End Sub

配列代入で式削除

2017–06–14 (Wed) 08:39
配列に代入し、式から文字列に変更します。
今までは、式から直接していましたが、今回のは配列なので、速度が違います。

Sub del()
nyuryoku = Selection.Address
Dim Sets As Variant
Dim SetsU As Long
Sets = Range(nyuryoku)
SetsU = UBound(Sets)
SetuL = UBound(Sets, 2)
For i = 1 To SetsU

For j = 1 To SetuL
On Error Resume Next
If Left(Sets(i, j), 1) = 0 Then
Sets(i, j) = "'" & Sets(i, j)
End If
If InStr(Sets(i, j), "-") <> 0 Then
Sets(i, j) = "'" & Sets(i, j)
End If
If Len(Sets(i, j)) > 10 Then
Sets(i, j) = "'" & Sets(i, j)
End If
If Left(Sets(i, j), 2) = "''" Then
Sets(i, j) = Right(Sets(i, j), Len(Sets(i, j)) - 2)
End If
On Error GoTo 0
Next
Next
Range(nyuryoku) = Sets
End Sub

 | HOME |  次へ »

プロフィール

あゆみ

Author:あゆみ
FC2ブログへようこそ!

最新記事

最新コメント

フリーエリア

月別アーカイブ

カテゴリ

ブロとも申請フォーム

検索フォーム

RSSリンクの表示

リンク