タイトル欄のアドレスは、エクセルファンクラブの該当する頁へのリンク先です。
詳しい事は、こちらのお願いをご覧になってください。
1 オートシェイプで作った図形や線などをセル範囲で指定して削除するには?
2 Shapeオブジェクトをシートの所定の位置に移動するには?
3 任意のセルの位置をポイントで表示するには?
4 選択したセルに、オートシェイプの○を書くには
5 セルの中に、オートシェイプの矢印を書く
6 セルの中に波線を書くには
7 鉄道を現すような、白黒線を書くには
8 太さや幅を指定できる二重線
9 シート内の全ての図形を削除するには
10 アクティブになっているグラフやテキストなどのオブジェクト名を取得するには
11 図形を指定のセルに移動
12 複数の図形を選択し、それぞれの名前、位置などを知るには
13 図形の位置を取得するには
14 図形の削除各種
15 図形のサイズを、セルに入力したミリの数値で変更するには
16 図形をアニメーションのように回転、移動、拡大するには?
17 図形を選択した時、色を変更するには
18 横並び、縦並びの3つの○を書くには?
19 図形描画で半円を描くには?
20 選択範囲に一回り小さい四角形を描くには?
1 | オートシェイプで作った図形や線などをセル範囲で指定して削除するには? |
B10からE20の中に収まっている図形を削除します。 Sub test() Dim wLeft As Long Dim wTop As Long Dim wRight As Long Dim wBottom As Long Dim s As Object With Range("B10:E20") wTop = .Top wLeft = .Left wBottom = .Top + .Height wRight = .Left + .Width End With For Each s In ActiveSheet.DrawingObjects With s If wTop <= .Top And _ wLeft <= .Left And _ wBottom >= .Top + .Height And _ wRight >= .Left + .Width Then .Delete End If End With Next End Sub このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 |
|
2 | Shapeオブジェクトをシートの所定の位置に移動するには? |
Excel2002確認済み Sub test() With ActiveSheet.Shapes(1) .Top = Range("E5").Top .Left = Range("E5").Left End With End Sub このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 |
|
3 | 任意のセルの位置をポイントで表示するには? |
Range("B2").Left
'セルB2 の左位置 Range("B2").Top 'セルB2 の上位置 |
|
4 | 選択したセルに、オートシェイプの○を書くには http://www.keep-on.com/~excelyou/2000lng1/200006/00060069.txt 「しるしを付けるには」 【編集ラウンジ】 |
Sub
選択されたセルの中にめいっぱいのサイズで○書く() Dim c As Range If Not TypeName(Selection) = "Range" Then Exit Sub For Each c In Selection With c.MergeArea If c.Address = .Item(1).Address Then ActiveSheet.Shapes.AddShape(msoShapeOval, .Left, .Top, _ .Width, .Height).Fill.Visible = False End If End With Next End Sub このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 |
|
Sub
選択されたセルに大きくまん丸に書く() Dim X As Double Dim Y As Double Dim L As Double Dim c As Range If Not TypeName(Selection) = "Range" Then Exit Sub For Each c In Selection With c.MergeArea If c.Address = .Item(1).Address Then L = IIf(.Width > .Height, .Height, .Width) X = .Left + (.Width - L) / 2 Y = .Top + (.Height - L) / 2 ActiveSheet.Shapes.AddShape(msoShapeOval, X, Y, L, L).Fill.Visible = False End If End With Next End Sub このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 |
|
選択したセルの中に等間隔に3つの丸を書きます Sub 等間隔に3つの丸を書く() Dim X(1 To 3) As Double Dim Y As Double Dim L As Double Dim c As Range If Not TypeName(Selection) = "Range" Then Exit Sub For Each c In Selection With c.MergeArea If c.Address = .Item(1).Address Then L = Application.WorksheetFunction.Min(.Height, .Width / 3) X(1) = .Left - L / 2 + (.Width / 6) X(2) = .Left - L / 2 + (.Width / 2) X(3) = .Left - L / 2 + (.Width / 6 * 5) Y = .Top + (.Height - L) / 2 With ActiveSheet.Shapes .AddShape(msoShapeOval, X(1), Y, L, L).Fill.Visible = False '左 .AddShape(msoShapeOval, X(2), Y, L, L).Fill.Visible = False '中央 .AddShape(msoShapeOval, X(3), Y, L, L).Fill.Visible = False '右 End With End If End With Next End Sub Sub 等間隔に小さな3つの丸を書く() Dim X(1 To 3) As Double Dim Y As Double Dim L As Double Dim c As Range If Not TypeName(Selection) = "Range" Then Exit Sub For Each c In Selection With c.MergeArea If c.Address = .Item(1).Address Then L = Application.WorksheetFunction.Min(.Height, .Width / 3) / 2 X(1) = .Left - L / 2 + (.Width / 6) X(2) = .Left - L / 2 + (.Width / 2) X(3) = .Left - L / 2 + (.Width / 6 * 5) Y = .Top + (.Height - L) / 2 With ActiveSheet.Shapes .AddShape(msoShapeOval, X(1), Y, L, L).Fill.Visible = False '左 .AddShape(msoShapeOval, X(2), Y, L, L).Fill.Visible = False '中央 .AddShape(msoShapeOval, X(3), Y, L, L).Fill.Visible = False '右 End With End If End With Next End Sub このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 |
|
5 | セルの中に、オートシェイプの矢印を書く http://www.keep-on.com/~excelyou/2000lng4/200006/00060163.txt 「オートシェイプで矢印を書くには」 【VBAラウンジ】 |
→以外の矢印の時は、msoShapeRightArrow
の部分をを、 ↑ の時は msoShapeUpArrow ← の時は msoShapeLeftArrow ↓ の時は msoShapeDownArrow に変更します。 Sub セル中央に縦横同サイズの→を書く() Dim X As Double, Y As Double, L As Double, c As Range If Not TypeName(Selection) = "Range" Then Exit Sub For Each c In Selection With c.MergeArea If c.Address = .Item(1).Address Then L = IIf(.Width > .Height, .Height, .Width) X = .Left + (.Width - L / 2) / 2 Y = .Top + (.Height - L / 2) / 2 ActiveSheet.Shapes.AddShape(msoShapeRightArrow, X, Y, L / 2, L / 2).Fill.Visible = False End If End With Next End Sub このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 |
|
Sub
選択したセルいっぱいに大きく→を書く() Dim c As Range If Not TypeName(Selection) = "Range" Then Exit Sub For Each c In Selection With c.MergeArea If c.Address = .Item(1).Address Then ActiveSheet.Shapes.AddShape(msoShapeRightArrow, .Left, _ .Top, .Width, .Height).Fill.Visible = False End If End With Next End Sub このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 |
|
Sub
アクティブセルにセル半分のサイズの→を書く() With ActiveCell ActiveSheet.Shapes.AddShape(msoShapeRightArrow, _ .Left + .Width / 4, _ .Top + .Height / 4, _ .Width / 2, _ .Height / 2) _ .Fill.Visible = False End With End Sub このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 |
|
6 | セルの中に、波線を書くには http://www.keep-on.com/~excelyou/2000lng4/200006/00060191.txt 「セルに波線を書くには?」 【VBAラウンジ】 |
Excel97、Excel2000 共通 1. 図形で直線を引きます。 2. オートシェイプの書式設定で線の色の線のパターンで右上の大波を選択します。 3. 線の太さを3ポイントにします。線の太さを6,9…と変えると2重,3重の波線が引けます。 |
|
Sub
セルの中に波線() Dim T As Double, L As Double, W As Double, H As Double Dim N As Variant, F As Variant, i As Integer If Not TypeName(Selection) = "Range" Then Exit Sub With Selection T = .Top L = .Left W = .Width H = .Height End With Do N = Application.InputBox("選択範囲にいくつの山を入れますか?", "整数入力", 5, Type:=1) If VarType(N) = vbBoolean Then Exit Sub If N > 0 And N = Int(N) Then Exit Do Loop Do F = Application.InputBox("線の太さを入力して下さい。", "太さ入力", 1.5, Type:=1) If VarType(F) = vbBoolean Then Exit Sub If F > 0 Then Exit Do Loop N = N * 2 With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, L, T) For i = 1 To N Step 2 .AddNodes msoSegmentCurve, msoEditingAuto, L + W / N * i, T + H .AddNodes msoSegmentCurve, msoEditingAuto, L + W / N * (i + 1), T Next .ConvertToShape.Line.Weight = F End With End Sub このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 |
|
Sub
セルの中にグラフ省略用の波線() Dim T As Double, L As Double, W As Double, H As Double Dim N As Variant, F As Variant, i As Integer, m(2) As String If Not TypeName(Selection) = "Range" Then Exit Sub With Selection T = .Top L = .Left W = .Width H = .Height End With Do N = Application.InputBox("選択範囲にいくつの山を入れますか?", "整数入力", 5, Type:=1) If VarType(N) = vbBoolean Then Exit Sub If N > 0 And N = Int(N) Then Exit Do Loop Do F = Application.InputBox("二本の線の間隔を入力して下さい。", "間隔入力", 6, Type:=1) If VarType(F) = vbBoolean Then Exit Sub If F > 0 Then Exit Do Loop N = N * 2 With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, L, T) For i = 1 To N Step 2 .AddNodes msoSegmentCurve, msoEditingAuto, L + W / N * i, T + H .AddNodes msoSegmentCurve, msoEditingAuto, L + W / N * (i + 1), T Next m(1) = .ConvertToShape.Name ActiveSheet.Shapes(m(1)).Line.Weight = F End With '外側の黒波線を描画 With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, L, T) For i = 1 To N Step 2 .AddNodes msoSegmentCurve, msoEditingAuto, L + W / N * i, T + H .AddNodes msoSegmentCurve, msoEditingAuto, L + W / N * (i + 1), T Next m(2) = .ConvertToShape.Name End With '内側の白波線を描画 With ActiveSheet.Shapes(m(2)) .Line.Weight = F - 3 .Line.ForeColor.SchemeColor = 9 End With '白・黒線をグループ化 ActiveSheet.Shapes.Range(Array(m(1), m(2))).Select Selection.ShapeRange.Group.Select End Sub このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 |
|
7 | 鉄道を現すような、白黒線を書くには http://www.keep-on.com/~excelyou/2000lng5/200006/00060071.txt 「罫線の種類について」 【その他ラウンジ】 |
Excel97、Excel2000 共通 セルの上と下に普通の罫線をひき、行間隔を詰めて、セルを交互に黒で塗りつぶす。 |
|
選択したセル
範囲の中に、任意の数だけ黒色を入れて、グループ化しています。 Sub 白黒線() Dim セル横幅 As Integer, セル縦幅 As Integer, 横位置 As Double, 高さ As Double Dim 黒の数 As Variant, 黒線の長さ As Integer, 黒 As Integer, i As Integer, c As Integer Dim 図形() As Variant If TypeName(Selection) <> "Range" Then Exit Sub With Selection セル横幅 = .Width セル縦幅 = .Height 横位置 = .Left 高さ = .Top End With Do 黒の数 = Application.InputBox("選択範囲にいくつ黒を入れますか?", "整数入力", 5, Type:=1) If VarType(黒の数) = vbBoolean Then Exit Sub If 黒の数 > 0 And 黒の数 = Int(黒の数) Then Exit Do Loop ReDim 図形(1 To 1) With ActiveSheet.Shapes With .AddShape(msoShapeRectangle, 横位置, 高さ, セル横幅, セル縦幅) .Fill.ForeColor.RGB = vbWhite 図形(1) = .Name End With 黒線の長さ = セル横幅 / 黒の数 / 2 黒 = 黒の数 * 2 - 1 c = 1 For i = 0 To 黒 Step 2 c = c + 1 ReDim Preserve 図形(1 To c) With .AddShape(msoShapeRectangle, 横位置 + 黒線の長さ * i, 高さ, 黒線の長さ, セル縦幅) .Fill.ForeColor.RGB = vbBlack 図形(c) = .Name End With Next .Range(図形).Group End With End Sub このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 |
|
8 | 太さや幅を指定できる二重線 |
Private
Type RECT Left As Single Top As Single Right As Single Bottom As Single End Type Sub DoubleLine() Dim CellRect As RECT Dim OuterRect As RECT Dim InnerRect As RECT Dim Distance As Variant Dim Direction As Variant Dim ArrLine() As Variant If TypeName(Selection) <> "Range" Then Exit Sub Do Distance = Application.InputBox("線の間隔を入力して下さい。" & vbCrLf & _ "Pt単位で(1Ptは1/72インチです。)", Title:="幅", Default:=3, Type:=1) If VarType(Distance) = vbBoolean Then Exit Sub If Distance > 0 Then Exit Do Loop Distance = Distance / 2 Do Direction = Application.InputBox("描画場所を指定して下さい。" & vbCrLf & _ "0:周り 1:上 2:下 3:左 4:右", Title:="作図位置", Default:=0, Type:=1) If VarType(Distance) = vbBoolean Then Exit Sub Select Case Direction Case 0, 1, 2, 3, 4 Exit Do End Select Loop With Selection CellRect.Left = .Left CellRect.Top = .Top CellRect.Right = .Left + .Width CellRect.Bottom = .Top + .Height End With With OuterRect .Left = CellRect.Left - Distance .Top = CellRect.Top - Distance .Right = CellRect.Right + Distance .Bottom = CellRect.Bottom + Distance End With With InnerRect .Left = CellRect.Left + Distance .Top = CellRect.Top + Distance .Right = CellRect.Right - Distance .Bottom = CellRect.Bottom - Distance End With ReDim ArrLine(1 To 2) With ActiveSheet.Shapes Select Case Direction Case 1 '上 ArrLine(1) = .AddLine(CellRect.Left, OuterRect.Top, CellRect.Right, OuterRect.Top).Name ArrLine(2) = .AddLine(CellRect.Left, InnerRect.Top, CellRect.Right, InnerRect.Top).Name Case 2 '下 ArrLine(1) = .AddLine(CellRect.Left, OuterRect.Bottom, CellRect.Right, _ OuterRect.Bottom).Name ArrLine(2) = .AddLine(CellRect.Left, InnerRect.Bottom, CellRect.Right, _ InnerRect.Bottom).Name Case 3 '左 ArrLine(1) = .AddLine(OuterRect.Left, CellRect.Top, OuterRect.Left, CellRect.Bottom).Name ArrLine(2) = .AddLine(InnerRect.Left, CellRect.Top, InnerRect.Left, CellRect.Bottom).Name Case 4 '右 ArrLine(1) = .AddLine(OuterRect.Right, CellRect.Top, OuterRect.Right, _ CellRect.Bottom).Name ArrLine(2) = .AddLine(InnerRect.Right, CellRect.Top, InnerRect.Right, CellRect.Bottom).Name Case Else '周り ReDim ArrLine(1 To 8) ArrLine(1) = .AddLine(OuterRect.Left, OuterRect.Top, OuterRect.Right, _ OuterRect.Top).Name ArrLine(2) = .AddLine(InnerRect.Left, InnerRect.Top, InnerRect.Right, InnerRect.Top).Name ArrLine(3) = .AddLine(OuterRect.Left, OuterRect.Bottom, OuterRect.Right, _ OuterRect.Bottom).Name ArrLine(4) = .AddLine(InnerRect.Left, InnerRect.Bottom, InnerRect.Right, _ InnerRect.Bottom).Name ArrLine(5) = .AddLine(OuterRect.Left, OuterRect.Top, OuterRect.Left, _ OuterRect.Bottom).Name ArrLine(6) = .AddLine(InnerRect.Left, InnerRect.Top, InnerRect.Left, _ InnerRect.Bottom).Name ArrLine(7) = .AddLine(OuterRect.Right, OuterRect.Top, OuterRect.Right, _ OuterRect.Bottom).Name ArrLine(8) = .AddLine(InnerRect.Right, InnerRect.Top, InnerRect.Right, _ InnerRect.Bottom).Name End Select .Range(ArrLine).Group End With End Sub 注意 : A列や1行目で使用すると上(左)の線幅が違ってきます。 このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 |
|
9 | シート内の全ての図形を削除するには http://www.keep-on.com/~excelyou/2000lng4/200006/00060191.txt 「セルに波線を書くには?」 【VBAラウンジ】 |
Sub
すべてのオブジェクトを削除() Dim s As Object With ActiveSheet If .ProtectDrawingObjects Then MsgBox "図形は保護されています。", vbCritical Else .DrawingObjects.Delete For Each s In .DrawingObjects s.Delete Next End If End With End Sub このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 |
|
Sub
すべてのオートシェイプを削除() Dim Sh As Shape With ActiveSheet If .ProtectDrawingObjects Then MsgBox "図形は保護されています。", vbCritical Else For Each Sh In ActiveSheet.Shapes If Sh.Type = msoAutoShape _ Or Sh.Type = msoLine _ Or Sh.Type = msoFreeform _ Or Sh.Type = msoGroup Then Sh.Delete End If Next End If End With End Su このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 |
|
10 | アクティブになっているグラフやテキストなどのオブジェクト名を取得するには |
Msgbox
Selection.Name で出ます。が、とにかく選択されているものになってしまうのでセルになったりいろいろになります。 |
|
11 | 図形を指定のセルに移動 http://cgi.fuji.ne.jp/~fj2094/cgi-bin1/wwwlng.cgi?print+200105/01050112.txt 「オートシェイプを印刷するとずれちゃいます(TT)」 【編集ラウンジ】 http://www.keep-on.com/~excelyou/2000lng4/200009/00090051.txt 「マクロで楕円を任意の場所に貼り付けたいのですが」 【VBAラウンジ】 |
Sub
指定のセルに図形の中央を合わせる() Dim seru As Range On Error GoTo Errorline Set seru = Application.InputBox("図形を移動するセルをクリックして下さい", "セルの選択", Type:=8) With Selection.ShapeRange .Left = seru.Left + seru.Width / 2 - .Width / 2 .Top = seru.Top + seru.Height / 2 - .Height / 2 End With Errorline: End Sub このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 |
|
Sub
指定のセルに図形の左上位置を合わせる() Dim seru As Range On Error GoTo Errorline Set seru = Application.InputBox("図形を移動するセルをクリックして下さい", "セルの選択", Type:=8) With Selection.ShapeRange .Left = seru.Left .Top = seru.Top End With Errorline: End Sub このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 |
|
12 | 複数の図形を選択し、それぞれの名前、位置などを知るには http://www.ae.wakwak.com/~efc21/cgi-bin/wwwlng.cgi?print+200011/00110404.txt 「複数の図形を選択し、それぞれの名前、位置などを知るには」 【VBAラウンジ】 |
図形オブジェクトを複数選択した状態では、Selection
プロパティがDrawingObjectsオブジェクトを返します。このコードは、選択した図形がひとつだけの場合は動きません。 結果をイミディエイトウインドウとメッセージボックスの両方に表示します。 Sub Test1() Dim obj As Object Dim i As Long If TypeName(Selection) = "DrawingObjects" Then i = 0 For Each obj In Selection i = i + 1 Debug.Print i, obj.Name, obj.Left, obj.Top, obj.Width, obj.Height MsgBox "Name = " & obj.Name & vbCrLf & _ "Left = " & obj.Left & vbCrLf & _ "Top = " & obj.Top & vbCrLf & _ "Width = " & obj.Width & vbCrLf & _ "Height = " & obj.Height Next End If End Sub 以下は、単独の図形を選択した場合にも対応させたコードです。 |
|
13 | 図形の位置を取得するには |
Sub
図形の位置取得() Dim 左 As Double, 上 As Double, 横幅 As Double, 縦幅 As Double Dim 右 As Double, 下 As Double If TypeName(Selection) = "Range" Then MsgBox "図形が選択されていません", vbCritical Exit Sub End If With Selection.ShapeRange If .Count > 1 Then MsgBox "図形は複数選択しないでください", vbCritical Exit Sub End If 左 = .Left 'セル の左位置 上 = .Top 'セル の上位置 横幅 = .Width 'セル の横幅 縦幅 = .Height 'セル の縦幅 右 = 左 + 横幅 'セル の右位置 下 = 上 + 縦幅 'セル の下位置 MsgBox "左位置は " & Format(左, "0.00") & " です" & vbCrLf & _ "上位置は " & Format(上, "0.00") & " です" & vbCrLf & _ "右位置は " & Format(右, "0.00") & " です" & vbCrLf & _ "下位置は " & Format(下, "0.00") & " です", Title:="図形の位置(ポイント)" End With End Sub このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 |
|
14 | 図形の削除各種 |
Sub
選択した図形を削除() Selection.Delete End Sub このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 |
|
Sub
アクティブシートの全ての図形を削除() ActiveSheet.DrawingObjects.Delete End Sub このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 |
|
Sub
三番目に挿入した図形を削除() ActiveSheet.DrawingObjects(3).Delete End Sub このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 |
|
Sub
図形を指定して削除() A% = Application.InputBox("消したい図形の番号を入れて下さい", Type:=1) Select Case A% Case False Exit Sub Case Else ActiveSheet.DrawingObjects(A%).Delete End Select End Sub このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 |
|
Sub
全シートの図形を削除() Dim WS As Worksheet For Each WS In Worksheets WS.DrawingObjects.Delete Next WS End Sub このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 |
|
15 | 図形のサイズを、セルに入力したミリの数値で変更するには http://www.ae.wakwak.com/~efc21/cgi-bin/wwwlng.cgi?print+200101/01010382.txt 「図形の自動サイズ変更」 【VBAラウンジ】 |
セルA1に幅、セルA2に高さをミリ単位で入力します。
Sub test() On Error GoTo Trap If Range("A1").Value <> 0 And Range("A2").Value <> 0 Then With Worksheets("sheet1").Rectangles(1) 'NO1の図形 .Width = Range("A1") / 0.35 'セル の横幅 .Height = Range("A2") / 0.35 'セル の縦幅 End With End If Trap: End Sub このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 |
|
このマクロでは、A1またはA2の数値を変更すると同時に、図形のサイズが変わります。 Private Sub Worksheet_Change(ByVal Target As Excel.Range) On Error GoTo Trap If Range("A1").Value <> 0 And Range("A2").Value <> 0 Then With Me.Rectangles(1) 'NO1の図形 .Width = Range("A1") / 0.35 'セル の横幅 .Height = Range("A2") / 0.35 'セル の縦幅 End With End If Trap: End Sub このコードの使い方は、マクロの使い方(2)該当するシートのモジュールにあります。 |
|
16 | 図形をアニメーションのように回転、移動、拡大するには? http://www.keep-on.com/~excelyou/2000lng4/200007/00070341.txt 「図形を拡大、縮小するには?」 【VBAラウンジ】 |
面白いので、試してみて下さい。 Sub IncrementShape() Dim MyShape As Shape Dim i As Long Set MyShape = ActiveSheet.Shapes.AddShape _ (msoShapeCan, 100, 100, 100, 100) With MyShape 'Shapeを回転させる For i = 1 To 360 .IncrementRotation 1 DoEvents Next i ' 右方向へ移動 For i = 1 To 300 .IncrementLeft 1 DoEvents Next i ' 図形の中心から拡大 For i = 1000 To 1050 .ScaleWidth 0.001 * i, False, msoScaleFromMiddle '(=1) .ScaleHeight 0.001 * i, False, msoScaleFromMiddle '(=1) DoEvents Next i '削除 '.Delete End With End Sub このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 |
|
17 | 図形を選択した時、色を変更するには http://www.ae.wakwak.com/~efc21/cgi-bin/wwwlng.cgi?print+200102/01020450.txt 「図形を選択した時に色を変える」 【VBAラウンジ】 |
Sub 図の色変更()
With ActiveSheet.Shapes(Application.Caller) If .Fill.ForeColor.SchemeColor = 9 Then .Fill.ForeColor.SchemeColor = 18 '塗りつぶし...濃い紺色 .Line.ForeColor.SchemeColor = 18 '枠線...濃い紺色 Else .Fill.ForeColor.SchemeColor = 9 '塗りつぶし...白 .Line.ForeColor.SchemeColor = 64 '枠線...自動 End If End With End Sub このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 コードを標準モジュールにコピーした後、図形を右クリック、マクロの登録をしてください。 マクロを登録した図形をクリックすると色が変わります。 |
|
このマクロでは、【開始】のマクロを実行すると、 図形を選択してをEnterしただけで選択した図形の色を変えることができるようになります。 【終了】のマクロを実行すると、Enterの設定が元に戻ります。 Sub 開始() |
|
18 | 横並び、縦並びの3つの○を書くには? http://www.ae.wakwak.com/~efc21/cgi-bin/wwwlng.cgi?print+200102/01020474.txt 「オートシェーブで書きたいんですが。」 【VBAラウンジ】 |
横並び、縦並びの3つの○を書きます。 '円の実験 Sub Test1() Call Oval1(1, True) ActiveCell.Offset(, 1).Activate Call Oval1(2, False) End Sub Sub Oval1(intPa As Integer, bolH As Boolean) '引数 'intPaint:黒塗りする位置 'bolH:向き(True:水平方向 False:垂直方向) Dim int2R As Integer Dim i As Integer With ActiveCell int2R = .Width / 3 If int2R > .Height Then int2R = .Height For i = 1 To 3 If bolH Then ActiveSheet.Shapes.AddShape(msoShapeOval, _ .Left + (i - 1) * int2R, .Top, int2R, int2R).Select Else ActiveSheet.Shapes.AddShape(msoShapeOval, _ .Left, .Top + (i - 1) * int2R, int2R, int2R).Select End If If intPa = i Then Selection.ShapeRange.Fill.ForeColor.SchemeColor = 8 Next i End With End Sub このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 |
|
上の○を、それぞれポイントで指定した間隔を空けて書きます。 Sub Test2() Call Oval2(1, 5, True) '間隔5Pt・横並びの○3つを描画(左端が●) ActiveCell.Offset(, 1).Activate Call Oval2(1, 5, False) '間隔5Pt・縦並びの○3つを描画(上端が●) End Sub Sub Oval2(intPa As Integer, intSeW As Integer, bolH As Boolean) Dim int2R As Integer Dim i As Integer With ActiveCell int2R = .Width / 3 If int2R > .Height Then int2R = .Height For i = 1 To 3 If bolH Then ActiveSheet.Shapes.AddShape(msoShapeOval, _ .Left + (i - 1) * (int2R + intSeW), .Top, int2R, int2R).Select Else ActiveSheet.Shapes.AddShape(msoShapeOval, _ 。Left, .Top + (i - 1) * (int2R + intSeW), int2R, int2R).Select End If If intPa = i Then Selection.ShapeRange.Fill.ForeColor.SchemeColor = 8 Next i End With End Sub このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 |
|
19 | 図形描画で半円を描くには? http://cgi.fuji.ne.jp/~fj2094/cgi-bin3/wwwlng.cgi?print+200104/01040022.txt 「図形描画で半円を」 【グラフ・図ラウンジ】 |
Sub Test() With ActiveCell With ActiveSheet.Shapes.AddShape(msoShapeBlockArc, .Left, .Top, 72#, 72#) .Adjustments.Item(1) = 0# .Adjustments.Item(2) = 0# .Flip msoFlipVertical End With End With End Sub このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 |
|
20 | 選択範囲に一回り小さい四角形を描くには? http://www.ae.wakwak.com/~efc21/cgi-bin/wwwlng.cgi?print+200105/01050043.txt 「こんなのありますか?」 【VBAラウンジ】 |
選択した範囲に、一つだけ四角形を書きます。 Sub 四角形記入() Const 余白率 = 20 '余白の割合(%) Dim 座標1 As Double, 座標2 As Double, 座標3 As Double, 座標4 As Double If TypeName(Selection) <> "Range" Then Exit Sub With Selection 座標1 = .Left + .Width * 余白率 / 100 座標2 = .Top + .Height * 余白率 / 100 座標3 = .Width * (100 - (余白率 * 2)) / 100 座標4 = .Height * (100 - (余白率 * 2)) / 100 End With ActiveSheet.Shapes.AddShape(msoShapeRectangle, _ 座標1, 座標2, 座標3, 座標4).Fill.ForeColor.SchemeColor = 13 End Sub このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 |
|
選択した範囲の全てのセルに、
余白の割合を指定して四角形を書きます。 Sub 選択範囲のセルに四角形を一つづつ記入() Dim 座標1 As Double, 座標2 As Double, 座標3 As Double, 座標4 As Double Dim 余白率 As Variant, c As Range Do 余白率 = Application.InputBox(Prompt:="余白の割合(10〜40)を入力してください", _ Default:=20, Type:=1) If VarType(余白率) = vbBoolean Then Exit Sub If 余白率 >= 10 And 余白率 <= 40 Then Exit Do Loop If TypeName(Selection) <> "Range" Then Exit Sub For Each c In Selection With c.MergeArea If c.Address = .Item(1).Address Then 座標1 = c.Left + c.Width * 余白率 / 100 座標2 = c.Top + c.Height * 余白率 / 100 座標3 = c.Width * (100 - (余白率 * 2)) / 100 座標4 = c.Height * (100 - (余白率 * 2)) / 100 ActiveSheet.Shapes.AddShape(msoShapeRectangle, _ 座標1, 座標2, 座標3, 座標4).Fill.ForeColor.SchemeColor = 13 End If End With Next End Sub このコードの使い方は、マクロの使い方(1)標準モジュールにあります。 |