【Excel】マクロでオートシェイプを挿入できますか？

Question

Excel2003を使用しています。

複数行、複数列に渡って、斜線を引きたいのですが、例えば、始点をアクティブセルとして、終点のセルを選択して、そこに直線(斜線)を挿入するようなことは可能でしょうか？
列数は11列と定まっているのですが、行数がそのときどきで違うので、セルを選択する方法を例として書きましたが、何か別の方法でもいいので、アドバイスいただけると嬉しいです。

また、このようなサイズの定まっていないオートシェイプをマクロで挿入することは無理ならば、今までは手動で斜線のサイズ調整等をしていますので、可能か不可能かだけでもわかると助かります。
よろしくお願いします。

Wendy02 · Accepted Answer

こんばんは。

このマクロは、実践では意外に難しいです。コードの構造はすごく単純なのですが、オートシェイプは、不明な誤動作が多いということです。ここでも、見えなくなるとかトラブルが出ています。何年もの間、失敗の連続から生まれたコードですが、自信はありません。

不明なトラブルは、だいたい、1,000回を過ぎるころからです。そのために、コードは補填しています。

その点で、#1さんの罫線側は、そのような報告は皆無です。


'Option Explicit
'標準モジュール
Sub LineDrawing()
　　Dim r1 As Range
　　Dim r2 As Range
　　
　　Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
　　
　　On Error Resume Next
　　Application.DisplayAlerts = False
　　Set r1 = Application.InputBox("最初のセルを設定してください", "LineDraw1", Type:=8)
　　Application.DisplayAlerts = True
　　If r1 Is Nothing Then Exit Sub
　　On Error GoTo 0
　　
　　
　　Application.Goto r1.Offset(, 10)
　　On Error Resume Next
　　Application.DisplayAlerts = False
　　Set r2 = Application.InputBox("最初のセル: '" & r1.Address(0, 0) & "'" & vbCrLf & _
　　　　　"二点目のセルを設定してください", "LineDraw2", Type:=8)
　　Application.DisplayAlerts = True
　　If r2 Is Nothing Then Exit Sub
　　On Error GoTo 0
　　
　　Union(r1, r2).Select
　　If MsgBox("'" & r1.Address(0, 0) & ":" & r2.Address(0, 0) & "'" & _
　　　　 vbCrLf & "でよろしいですか？", _
　　vbInformation + vbOKCancel) = vbCancel Then Exit Sub
　　
　　'+以降で、線を中央に動かしている,微調整は、ここでする
　　
　　x1 = r1.Left + Int(r1.Width / 2)
　　y1 = r1.Top + Int(r1.Height / 2)
　　x2 = r2.Left + Int(r2.Width / 2)
　　y2 = r2.Top + Int(r2.Height / 2)
　　
　　
　　With ActiveSheet.Shapes.AddLine(x1, y1, x2, y2)
　　
　　'オプション（色だけは指定したほうが良い Verよって誤動作する）
　　　 .Line.Weight = 0.75
　　　 .Line.Visible = msoTrue
　　　 .Line.ForeColor.SchemeColor = 8 '黒
　　'セルに何度も使う場合は無駄と思っても必ず入れる,入れないと消える
　　　.Visible = True　　　 
　　End With
　　r2.Select
　　Set r1 = Nothing: Set r2 = Nothing
　　'画面が切り替わらないときは、ここを外してください。
　　'Application.ScreenUpdating = True
End Sub

ham_kamo · Answer

こんにちは、ham_kamoです。

> オートシェイプの種類で、直線と同じような『直線コネクタ』と
> いうのがありますが、これは、『直線』とどのような違いが
> あるのでしょうか？

直線コネクタに限らず、コネクタ類のオートシェイプは、他の図形と結合することができます。

たとえば、直線コネクタを一本引き、次に四角形を描きます。すると、四角形の四隅と各辺の中央に□マークが現れます。直線コネクタの端をドラッグして四角形の辺の真ん中の□マークに近づけると、青い印が現れて、その状態でドロップすると赤い□マークに変わります。これで直線と四角形が結合されます。

その状態で四角形を移動すると、直線コネクタがついてくると思います。もう一つ四角形を追加して、直線コネクタのもう一つの端をそちらの四角形に連結し、図形をいろいろ移動してみると、どんな感じかわかると思います。要は、図形を描画するときにその位置関係を保つように「コネクト」するのがコネクタなのです。

したがって、単に直線１本ひくだけなら、直線コネクタでも単なる直線でも、どちらでもかまわないと思います。ちなみに、どちらもAltキーを押しながら調整すると、セルにぴったりあわせて端の位置を調整することができます。

Wendy02 · Answer

こんにちは。Wendy02です。

#5 
セルには、
>マクロでは、 Right や Bottom という書き方はしないということでしょうか？

というか、プロパティはなかったはずです。

Wendy02 · Answer

こんにちは。Wendy02です。

オートシェイプだけは、たぶん、教本では学ぶことが出来ませんね。細かく出ている本を見たことがありません。私の書くのは、どうしようもない失敗の連続から学んだものですが、これは、VBとも違いますので、私は難しく思います。

>この中の Left や Top を Right や Bottom に変更することはできるのでしょうか？

Top
　↓ ←Left 
　 +----------------+ 　　↑
　 |　　セル　　　　　　　　 |　 Height
　 |　　r1　　　　　　　　　　 |　　↓
　 +----------------+
　 　←　Width →
　 　
ということになっていますから、

Right ということになると、r1.Left + r1.Width

つまり、言い換えると、r1.Offset(,1).Left と同じことになります。

Bottom は、r1.Top + r1.Height 

つまり、言い換えると、r1.Offset(1).Top と同じことになります。

なお、前回のコードのミスですが、[Int(r1.Width / 2)]　は、もともと、Double 型でしたので、あえて、Int で整数にする必要がありませんでした。[r1.Width / 2]で可能です。

ham_kamo · Answer

No.2のham_kamoです。
右上から左下への斜線だったのですね。
マクロを修正してみました。
昨日は何か勘違いして、マクロで余計な処理をしており、不要なFunctionを作っていましたが、今回は不要です。昨日のマクロは全部ばっさり削除して、以下のマクロに置きかえてみてください。

Sub 斜線を引く()
　Dim BeginX As Long, BeginY As Long
　Dim EndX As Long, EndY As Long
　With Selection
　　BeginY = .Cells(1).Top
　　BeginX = .Cells(.Cells.Count).Left + .Cells(.Cells.Count).Width
　　EndX = .Cells(1).Left
　　EndY = .Cells(.Cells.Count).Top + .Cells(.Cells.Count).Height
　End With
　
　ActiveSheet.Shapes.AddLine BeginX, BeginY, EndX, EndY
End Sub

ham_kamo · Answer

マウスで選択した範囲に、左上から右下に斜線を挿入するマクロです。
Alt+F11でVBAの画面を開き、左側のツリーからブック名を選択し、右クリックから「挿入」＞「標準モジュール」を選択して、右の画面に以下のマクロをコピーして貼り付けてください。

Sub 斜線を引く()
　If Selection.Cells.Count < 2 Then
　　MsgBox "２つ以上のセルを選択してください。"
　　Exit Sub
　End If
　
　Dim BeginX As Long, BeginY As Long
　Dim EndX As Long, EndY As Long
　With Selection
　　BeginX = GetPosX(.Cells(1))
　　BeginY = GetPosY(.Cells(1))
　　EndX = GetPosX(.Cells(.Cells.Count).Offset(1, 1)) - 1
　　EndY = GetPosY(.Cells(.Cells.Count).Offset(1, 1)) - 1
　End With
　
　ActiveSheet.Shapes.AddLine BeginX, BeginY, EndX, EndY
End Sub

Function GetPosX(R As Range) As Long
　If R.Column = 1 Then
　　GetPosX = 0
　Else
　　GetPosX = Range(Cells(1, 1), Cells(1, R.Column - 1)).Width
　End If
End Function

Function GetPosY(R As Range) As Long
　If R.Row = 1 Then
　　GetPosY = 0
　Else
　　GetPosY = Range(Cells(1, 1), Cells(R.Row - 1, 1)).Height
　End If
End Function

シート上で斜線を引きたい範囲をマウスで選択し（始点と終点でなく、範囲全体を選択してください）、マクロを実行してください。

ASIMOV · Answer

セルの位置が判るのでしたら、斜め罫線ではどうでしょうか

例えば
-------------------
Sub naname()
　Range("A1").Select
　With Selection.Borders(xlDiagonalUp)
　　.LineStyle = xlContinuous
　　.Weight = xlThin
　　.ColorIndex = xlAutomatic
　End With
End Sub
------------------
で、A1に斜めに線が引けます

【Excel】マクロでオートシェイプを挿入できますか？

こんばんは。

こんにちは、ham_kamoです。

こんにちは。

こんにちは。

No.2のham_kamoです。

マウスで選択した範囲に、左上から右下に斜線を挿入するマクロです。

セルの位置が判るのでしたら、斜め罫線ではどうでしょうか

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング