- ベストアンサー
ExcelのVBAでオートシェイプの矢印を挿入する方法
- ExcelのVBAを使用して、セル内にオートシェイプの矢印を挿入する方法について教えてください。
- 具体的には、指定したセルの間に矢印を挿入し、矢印の細い部分が一方のセルを、矢印の頭の部分がもう一方のセルを指すようにしたいです。
- また、矢印が挿入されるセルは、指定された範囲内であり、関連するセルに数字や文字が含まれる場合もあります。
- みんなの回答 (3)
- 専門家の回答
質問者が選んだベストアンサー
以下の解釈でよろしいですか? 矢印を引くルールは、A列のみで決まり、B,C,D,F,G,Hはチェックしなくて良い。 行と列を転地した場合、以下のようになる。但し、以下例にて、E列に引かれる複数の矢印を1行ごとにばらして表現しているが、実際にはすべて同一ライン上に重なる。 A列 建落建落落建落落落 E列 -→ E列 -→ E列 --→ E列 -→ E列 --→ E列 ---→ 細かい話ですが、矢印の始点は建のある行のどの高さになりますか。 行の上端/真ん中/下端とかで表現できますか? 終点はどうですか?
その他の回答 (2)
- Raistlin
- ベストアンサー率63% (65/102)
1つ目のEnd Subの前の以下3行は消し忘れのごみです。すみません。 >Exit Sub > >Call AddArrwS1(1, 8, 9) 実害ありませんが念のため(;´ー`)>
- Raistlin
- ベストアンサー率63% (65/102)
コードの柔軟性、速度ばっかり考えていると恐ろしく長くなってしまいましたが、できました。 定数7個をご自身の環境に合わせて変更の上、処理対象シートを表示後に実行してしてください。 注意点 ・全ての"落"行を一度に処理するコードです。 ・作成した矢印には、終点の行に対応した名前をつけます。 ・複数回実行の場合、既に存在する矢印と同じ名前の矢印を作成しようとする時のみいったん削除するので、矢印と終点行の関係が崩れていると修正できません。 ・行高さが一定であることを前提としています Option Base 1 '対象シートの座標より初期設定 Const LC_LEFT As Single = 216 '矢印列左 Const LC_RIGHT As Single = 270 '矢印列+1列左 Const LC_RWHGHT As Single = 14.25 '行高さ Sub AddArrw() '初期設定部 Const lStrtRw As Long = 3 'データ開始行 Const lCls As Long = 1 '区分列番号 Const lUri As Long = 4 '売りグループデータ列番号 Const lKai As Long = 6 '買いグループデータ列番号 Dim TrgtSht As Worksheet Dim vCls As Variant '区分データ格納 Dim vUri As Variant '売りグループデータ格納 Dim vKai As Variant '買いグループデータ格納 Dim lLstRw As Long 'データ最終行格納 Dim CurShp As Object 'ループ用オブジェクト変数 Dim i As Long, j As Long 'ループカウンタ Set TrgtSht = ActiveSheet With TrgtSht 'データ最終行確認>データを配列に格納 lLstRw = .Cells(65536, lCls).End(xlUp).Row vCls = .Range(.Cells(lStrtRw, lCls), .Cells(lLstRw, lCls)) vUri = .Range(.Cells(lStrtRw, lUri), .Cells(lLstRw, lUri)) vKai = .Range(.Cells(lStrtRw, lKai), .Cells(lLstRw, lKai)) '区分データを下からチェックして"落"の行を探す For i = UBound(vCls) To 1 Step -1 If vCls(i, 1) = "落" Then '当該行に対応した矢印が既にある時、いったん削除 For Each CurShp In .Shapes With CurShp If .Name = "Arrw" & Format(i + lStrtRw - 1, "00000") Then .Delete End If End With Next CurShp '当該行の売りグループデータが空白かどうかチェック If vUri(i, 1) <> "" Then '真なら売りデータに対応する買いデータの行を探す For j = i - 1 To 1 Step -1 If vKai(j, 1) = vUri(i, 1) Then '矢印引きルーチンを呼ぶ Call AddArrwS1(1, j + lStrtRw - 1, i + lStrtRw - 1) Exit For End If Next j Else '右向き矢印の処理 For j = i - 1 To 1 Step -1 If vUri(j, 1) = vKai(i, 1) Then Call AddArrwS1(0, j + lStrtRw - 1, i + lStrtRw - 1) Exit For End If Next j End If End If Next i End With Exit Sub Call AddArrwS1(1, 8, 9) End Sub Sub AddArrwS1(iDir As Integer, lBgn As Long, lEnd As Long) '矢印引きルーチン ' iDir: 矢印方向 0=右向き 1=左向き ' lBgn: 始点行, lEnd: 終点行 Dim sBX As Single '始点X座標 Dim sEX As Single '終点X座標 '矢印の向きにあわせて始点/終点のX座標設定 Select Case iDir Case 0 sBX = LC_LEFT: sEX = LC_RIGHT Case 1 sBX = LC_RIGHT: sEX = LC_LEFT Case Else Exit Sub End Select '始点行から終点行に線描画>命名>終点に矢印スタイル設定 With ActiveSheet.Shapes.AddLine(sBX, LC_RWHGHT * (lBgn - 0.5), sEX, LC_RWHGHT * (lEnd - 0.5)) .Name = "Arrw" & Format(lEnd, "00000") With .Line .EndArrowheadStyle = msoArrowheadTriangle .EndArrowheadLength = msoArrowheadLengthMedium .EndArrowheadWidth = msoArrowheadWidthMedium End With End With End Sub ところでこれ、何の記録ですか? ##### Select, Activateゼロ化運動中 #####
補足
回答ありがとうございます。 まず、ルールは必ず「建」から「落」に矢印(「落」を指している)。 矢印というのは、オートシェイプで引きたいのです。 何故かというと、イメージで言うと「F3」から「D4」に矢印と引くことになるからです。矢印が同じ行になることは絶対にないのです。必ず1行では「建」・「落」のどちらかです。 それとイメージの状態ではならないのですが、矢印が交差することもあります。 「建」「建」と2行連続できて、2行目の方を先に「落」にする場合もあるからです。 それと、矢印は「D」と「F」のグループが同じものに引くことになります。 矢印の始点・終点の場所は「E」列の間で、位置は「E」の端から端。高さは真ん中です。 参考 始点「F3」→「D4」 始点「D5」→「F6」と「F7」 始点「F8」→「D9」と「D10」と「D11」の 矢印を挿入するところは「E」列です。 説明が下手で申し訳ないのですがどうでしょうか?