■Cellをカギ線コネクタでつないでみる

厳密に言うと（言わなくても：D）やっぱり Shape を繋ぐのだが。
誰も昨日のが前フリだとは思わなかったに違いない...私もだけど。

今日のは Sheet モジュールに置いて、BeforeDoubleClick イベントで起動。
直線コネクタを軌跡の替わりにしてセルとセルを繋ぐ...
ように見せかけてセルに被せた Rectangle を Connect してみるのである。



仮の直線コネクタの始点をポイントするために、Win32API の mouse_event を使ってます。
コメントにも書いてますが本来は SendInput を使うのが望ましいみたい。
とりあえず簡易版で。

'SheetModule
Option Explicit

Private Declare Sub mouse_event Lib "user32.dll" ( _
　　　　　　　　　　　　　　　　ByVal dwFlags As Long, _
　　　　　　　　　　　　　　　　ByVal dx As Long, _
　　　　　　　　　　　　　　　　ByVal dy As Long, _
　　　　　　　　　　　　　　　　ByVal cButtons As Long, _
　　　　　　　　　　　　　　　　ByVal dwExtraInfo As Long)

Private Declare Function GetAsyncKeyState Lib "user32.dll" ( _
　　　　　　　　　　　　　　　　　　　　　ByVal vKey As Long) As Long

Private Const MOUSEEVENTF_LEFTUP = &H4
Private Const MOUSEEVENTF_LEFTDOWN = &H2
Private Const VK_LBUTTON = &H1
'-------------------------------------------------
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
　　　　　　　　　　　　　　　　　　　　Cancel As Boolean)
　　Dim rEnd As Range　 '終点セル
　　Dim flg　As Boolean 'マウスクリック判定
　　Dim msg　As String　'メッセージ用
　　Dim i　　As Long

　　Cancel = True
　　'直線コネクタを使ってマウスの軌跡線にしてみた
　　CommandBars.FindControl(ID:=1042).accDoDefaultAction
　　'簡易的なもの。推奨はSendInput（？）
　　Call mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0)
　　Call mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0)
　　'本来はDo Loopでいいはずなのだが...
　　For i = 1 To 1000
　　　　DoEvents
　　　　flg = (GetAsyncKeyState(VK_LBUTTON) < 0&)
　　　　If flg Then Exit For
　　Next
　　'終点セルのセット
　　With Me.Shapes
　　　　With .Item(.Count)
　　　　　　If flg Then
　　　　　　　　If .VerticalFlip Then
　　　　　　　　　　If .HorizontalFlip Then
　　　　　　　　　　　　Set rEnd = .TopLeftCell
　　　　　　　　　　Else
　　　　　　　　　　　　Set rEnd = Me.Cells(.TopLeftCell.Row, _
　　　　　　　　　　　　　　　　　　　　　　.BottomRightCell.Column)
　　　　　　　　　　End If
　　　　　　　　Else
　　　　　　　　　　If .HorizontalFlip Then
　　　　　　　　　　　　Set rEnd = Me.Cells(.BottomRightCell.Row, _
　　　　　　　　　　　　　　　　　　　　　　.TopLeftCell.Column)
　　　　　　　　　　Else
　　　　　　　　　　　　Set rEnd = .BottomRightCell
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　End If
　　　　　　.Delete
　　　　End With
　　End With
　　If flg Then
　　　　'起点セル,終点セルを元にShape描画
　　　　Call spConnect(Target, rEnd)
　　Else
　　　　'バグがありそうなのでその対策。
　　　　With ActiveWindow
　　　　　　If .Zoom > 100 Then
　　　　　　　　.Zoom = 100
　　　　　　　　msg = " with Zoom 100"
　　　　　　End If
　　　　End With
　　　　MsgBox "Retry" & msg
　　End If
　　Set rEnd = Nothing
End Sub
'-------------------------------------------------
Private Sub spConnect(ByRef rBgn As Range, ByRef rEnd As Range)
　　Dim sp(2) As Shape
　　Dim i　　 As Long

　　With Me.Shapes
　　　　'起点セル
　　　　Set sp(0) = .AddShape(msoShapeRectangle, _
　　　　　　　　　　　　　　　rBgn.Left, rBgn.Top, rBgn.Width, rBgn.Height)
　　　　'終点セル
　　　　Set sp(1) = .AddShape(msoShapeRectangle, _
　　　　　　　　　　　　　　　rEnd.Left, rEnd.Top, rEnd.Width, rEnd.Height)
　　　　'カギ線コネクタ
　　　　Set sp(2) = .AddConnector(msoConnectorElbow, 0, 0, 0, 0)
　　End With
　　For i = 0 To 1
　　　　With sp(i)
　　　　　　.Fill.Visible = msoFalse
　　　　　　.Placement = xlMoveAndSize
　　　　　　.Line.Weight = 1
　　　　　　.Line.ForeColor.RGB = vbBlue
　　　　End With
　　Next
　　With sp(2)
　　　　With .ConnectorFormat
　　　　　　.BeginConnect sp(0), 4
　　　　　　.EndConnect sp(1), 2
　　　　End With
　　　　.Line.Weight = 1
　　　　.Line.ForeColor.RGB = vbBlue
　　　　'最短経路で再接続
　　　　.RerouteConnections
　　End With

　　Set sp(0) = Nothing
　　Set sp(1) = Nothing
　　Set sp(2) = Nothing
End Sub

軌跡用に直線コネクタを使ったのは、Line だとクリック＆ドラッグでの描画になるのに対し、クリック＆ムーブ＆クリックで描画できるからなのです。
でも、もしかして『 Zoom の拡大率によってはドラッグしないといけない時もある』というようなバグが潜んでる？
そんな情報あったっけっかなぁ...

あと、隣接するセル同士をコネクトするとちとヘンです。
RerouteConnections メソッドを使ってるからなのでしょうけど。
解消するにはもうひと工夫必要みたいですね...。でも、それほど実用的とも思えないのでとりあえずこの辺りで ：D

■Shapeをカギ線コネクタでつないでみる

oshiete1.goo.ne.jp の『このQ&Aについてブログを書く』ってやつをちょっとやってみたかっただけなの ：D
マクロの登録を使って、オートシェイプどうしをカギ線矢印コネクタでつなぐ - 教えて！goo

ちょっと前のQ&Aで、Rectangle に OnAction でマクロ登録してコネクタで繋ぐというやつです。

Option Explicit

Sub prep() 'テストシート作成
　　Dim i As Long

　　With Sheets.Add
　　　　For i = 1 To 4
　　　　　　With .Rectangles.Add(i * 50, i * 30, 30, 10)
　　　　　　　　.Interior.Color = vbBlue
　　　　　　　　.OnAction = "try"
　　　　　　End With
　　　　Next
　　End With
End Sub
'-------------------------------------------------
Sub try()
　　Static x As String
　　Dim ws　 As Worksheet

　　If Len(x) = 0 Then
　　　　If MsgBox("connect?", vbYesNo) = vbNo Then Exit Sub
　　　　x = Application.Caller
　　Else
　　　　Set ws = ActiveSheet
　　　　With ws.Shapes.AddConnector(msoConnectorElbow, 0, 0, 0, 0)
　　　　　　.Line.EndArrowheadStyle = msoArrowheadTriangle
　　　　　　With .ConnectorFormat
　　　　　　　　.BeginConnect ws.Shapes(x), 4
　　　　　　　　.EndConnect ws.Shapes(Application.Caller), 2
　　　　　　End With
　　　　　　'.RerouteConnections '最短経路で再接続
　　　　End With
　　　　x = ""
　　　　Set ws = Nothing
　　End If
End Sub

余談ではありますが、最初のレスでエラーが出たのは多分2007の環境だったのでしょう。
>With ActiveSheet
>　　With .Shapes.AddConnector(msoConnectorElbow, 0, 0, 0, 0)
>　　　　.Line.EndArrowheadStyle = msoArrowheadTriangle
>　　　　.ConnectorFormat.BeginConnect .Parent.Shapes(x), 4
この Parentプロパティ が曲者のようです。
2007からは Shape の 親は Shapes になったみたい。

■損益分岐点グラフ

雑記です。
すぐどっかいっちゃうので備忘録的に置かせてください。

損益分岐点グラフ雛形作成マクロ。基本的には一般操作の範疇。

Option Explicit

Sub try()
　　Const CLSID_DataObject = "1C3B4210-F441-11CE-B9EA-00AA006B1A69"
　　'DataObjectのClassID。事後バインディング用 _
　　 参考http://www.vbalab.net/vbaqa/c-board.cgi?cmd=ntr;tree=55281;id=excel
　　Dim sDATA As String

　　'デフォルトデータ
　　sDATA = "損益分岐点グラフ||軸|0|=MAX(B8*2,B2*1.5)" _
　　　　　& "¥総売上|10000000|収益線|0|=E1" _
　　　　　& "¥変動費|6000000|費用線|=B4|=B3/B2*E2+E4" _
　　　　　& "¥固定費|3000000|固定費|=B4|=B4" _
　　　　　& "¥損益|=B2-B3-B4|損益分岐点|=B8|=B8" _
　　　　　& "¥変動比率|=B3/B2|損益分岐点y値|0|=B8" _
　　　　　& "¥限界利益率|=1-B6|当期売上|=B2|=B2" _
　　　　　& "¥損益分岐点売上|=B4/B7|当期売上y値|0|=B2" _
　　　　　& "¥||当期損益|=B2|=B2" _
　　　　　& "¥||当期損益y値|=B2|=B2-B5"

　　sDATA = Replace(Replace(sDATA, "|", vbTab), "¥", vbLf)
　　With GetObject("new:" & CLSID_DataObject)
　　　　.SetText sDATA
　　　　.PutInClipboard
　　End With
　　With Sheets.Add 'ActiveSheet
　　　　.Paste .Range("A1")
　　　　With .Range("A1").CurrentRegion
　　　　　　.NumberFormat = "#,##0,"
　　　　　　.Range("B6:B7").NumberFormat = "0.00%"
　　　　　　.EntireColumn.AutoFit
　　　　End With
　　　　With .Range("B2:B4")
　　　　　　.Borders.Weight = xlThin
　　　　　　.Interior.ColorIndex = 34
　　　　End With
　　End With
　　Call gDraw
End Sub

Sub gDraw()
　　Dim ws As Worksheet
　　Dim pa As PlotArea
　　Dim r　As Range　　'追加系列範囲用
　　Dim h　As Single　 'Chartサイズ用
　　Dim w　As Single　 'Chartサイズ用
　　Dim i　As Long
　　Dim x

　　Set ws = ActiveSheet
　　With ws.Range("A1").CurrentRegion
　　　　w = .Width
　　　　h = .Height
　　　　Set r = .Range("C5,D5:E5,D6:E6")
　　End With
　　With ws.ChartObjects.Add(0, h, w, h * 2).Chart
　　　　'まずC1:E4範囲で散布図グラフ作成
　　　　.ChartType = xlXYScatterLinesNoMarkers
　　　　.SetSourceData Source:=ws.Range("C1:E4"), _
　　　　　　　　　　　 PlotBy:=xlRows
　　　　'系列を追加し x,y値を設定し垂線を引く
　　　　For i = 0 To 4 Step 2
　　　　　　With .SeriesCollection.NewSeries
　　　　　　　　.Name = r.Offset(i).Areas(1)
　　　　　　　　.XValues = r.Offset(i).Areas(2)
　　　　　　　　.Values = r.Offset(i).Areas(3)
　　　　　　End With
　　　　Next
　　　　'系列のColorIndex設定
　　　　i = 0
　　　　For Each x In Array(1, 3, 4, 6, 5, 8)
　　　　　　i = i + 1
　　　　　　.SeriesCollection(i).Border.ColorIndex = x
　　　　Next
　　　　'軸の最小値|最大値を設定
　　　　For i = 1 To 2 '1=xlCategory:2=xlValue
　　　　　　With .Axes(i)
　　　　　　　　.MinimumScale = 0
　　　　　　　　.MaximumScale = ws.Range("E1").Value
　　　　　　End With
　　　　Next
　　　　'タイトルをセル連動
　　　　.HasTitle = True
　　　　.ChartTitle.Text = "=" & ws.Name & "!R1C1"
　　　　'プロットエリアのサイズ設定
　　　　Set pa = .PlotArea
　　　　With .ChartArea
　　　　　　.AutoScaleFont = False
　　　　　　.Font.Size = 9
　　　　　　pa.Width = .Width
　　　　　　pa.Height = .Height
　　　　End With
　　　　'凡例の位置設定
　　　　With .Legend
　　　　　　.Left = pa.InsideLeft
　　　　　　.Top = pa.InsideTop
　　　　End With
　　End With

　　Set r = Nothing
　　Set pa = Nothing
　　Set ws = Nothing
End Sub

あとは必要に応じてシートにイベントプロシージャを置く。など。

'SheetModule
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim x As Long

　　If Not Intersect(Target, Me.Range("B2:B4")) Is Nothing Then
　　　　x = Me.Range("E1").Value
　　　　With Me.ChartObjects(1).Chart
　　　　　　.Axes(xlValue).MaximumScale = x
　　　　　　.Axes(xlCategory).MaximumScale = x
　　　　End With
　　End If
End Sub

■配列書き込み時のClearContents

シート上に２次元配列を書き込む時、その範囲に既に値があると書き込みの速度が遅くなるため、[ClearContents メソッド]は必須です。
こんなコードで検証できます。

Option Explicit

Private Declare Function timeGetTime Lib "winmm.dll" () As Long
'-------------------------------------------------
Sub try()
　　Const x = 100　'テストデータ列数
　　Const y = 1000 'テストデータ行数
　　Const z = 10　 'テスト回数
　　Const n = z + 1
　　Dim ws As Worksheet
　　Dim t　As Long
　　Dim i　As Long
　　Dim v, w(n, 2)

　　Application.ScreenUpdating = False
　　With Workbooks.Add(xlWBATWorksheet)
　　　　With .Worksheets(1).Cells(1).Resize(y, x)
　　　　　　.Value = "abcde"
　　　　　　w(0, 1) = "クリアなし"
　　　　　　w(0, 2) = "クリアあり"
　　　　　　For i = 1 To z
　　　　　　　　w(i, 0) = i
　　　　　　　　t = timeGetTime
　　　　　　　　v = .Value
　　　　　　　　.Value = v
　　　　　　　　w(i, 1) = timeGetTime - t
　　　　　　　　t = timeGetTime
　　　　　　　　v = .Value
　　　　　　　　.ClearContents
　　　　　　　　.Value = v
　　　　　　　　w(i, 2) = timeGetTime - t
　　　　　　　　w(n, 1) = w(n, 1) + w(i, 1)
　　　　　　　　w(n, 2) = w(n, 2) + w(i, 2)
　　　　　　Next
　　　　　　w(n, 0) = "平均"
　　　　　　w(n, 1) = w(n, 1) / z
　　　　　　w(n, 2) = w(n, 2) / z
　　　　End With
　　　　Set ws = .Sheets.Add
　　　　With ws
　　　　　　.Cells(1).Resize(n + 1, 3).Value = w
　　　　　　'以下Chart作成.なくても良い
　　　　　　With .ChartObjects.Add(200, 0, 250, 200).Chart
　　　　　　　　.ChartType = xlColumnClustered
　　　　　　　　.SetSourceData Source:=ws.Range("B1:C1").Resize(n), _
　　　　　　　　　　　　　　　 PlotBy:=xlColumns
　　　　　　　　For i = 1 To 2
　　　　　　　　　　With .SeriesCollection.NewSeries
　　　　　　　　　　　　.Values = Array(w(n, i), w(n, i))
　　　　　　　　　　　　.ChartType = xlLine
　　　　　　　　　　　　.Border.LineStyle = xlNone
　　　　　　　　　　　　With .Trendlines.Add
　　　　　　　　　　　　　　.Type = xlLinear
　　　　　　　　　　　　　　.Forward = z - 1.5
　　　　　　　　　　　　　　.Backward = 0.5
　　　　　　　　　　　　　　.Border.Weight = xlMedium
　　　　　　　　　　　　　　.Border.ColorIndex = 5 - i
　　　　　　　　　　　　　　.Name = w(0, i) & w(n, 0)
　　　　　　　　　　　　End With
　　　　　　　　　　End With
　　　　　　　　Next
　　　　　　　　.HasLegend = True
　　　　　　　　With .Legend
　　　　　　　　　　.Position = xlTop
　　　　　　　　　　For i = 4 To 3 Step -1
　　　　　　　　　　　　.LegendEntries(i).Delete
　　　　　　　　　　Next
　　　　　　　　End With
　　　　　　End With
　　　　　　'以上Chart作成
　　　　End With
　　End With
　　Application.ScreenUpdating = True
　　Set ws = Nothing
End Sub

結果。


ぁ、あれ？......である。

実はこれ[winVista / xl2007 | xl2000]の混在環境で実行したもの。私のメイン環境の[win2000 / xl2000]ではちゃんと逆の結果になります。
では2007は、というと



こういう結果。フリーズしたのかと思うほど遅い。
個々に見ると、
ClearContents が遅いようです。

Option Explicit

Private Declare Function timeGetTime Lib "winmm.dll" () As Long
'-------------------------------------------------
Private Function timechk(t As Long) As Long
　　Static chk As Long
　　timechk = t - chk
　　chk = t
End Function
'-------------------------------------------------
Sub try2()
　　Const x = 100
　　Const y = 1000
　　Dim v, w(4, 2)

　　Application.ScreenUpdating = False
　　With Workbooks.Add(xlWBATWorksheet)
　　　　With .Sheets(1).Cells(1).Resize(y, x)
　　　　　　.Value = "abcde"
　　　　　　w(0, 1) = "クリアなし"
　　　　　　w(0, 2) = "クリアあり"
　　　　　　w(1, 0) = "v = .Value"
　　　　　　w(2, 0) = ".ClearContents"
　　　　　　w(3, 0) = ".Value = v"
　　　　　　w(4, 0) = "計"
　　　　　　Call timechk(timeGetTime)
　　　　　　v = .Value
　　　　　　w(1, 1) = timechk(timeGetTime)
　　　　　　.Value = v
　　　　　　w(3, 1) = timechk(timeGetTime)
　　　　　　v = .Value
　　　　　　w(1, 2) = timechk(timeGetTime)
　　　　　　.ClearContents
　　　　　　w(2, 2) = timechk(timeGetTime)
　　　　　　.Value = v
　　　　　　w(3, 2) = timechk(timeGetTime)
　　　　End With
　　　　w(4, 1) = w(1, 1) + w(2, 1) + w(3, 1)
　　　　w(4, 2) = w(1, 2) + w(2, 2) + w(3, 2)
　　　　.Sheets.Add.Cells(1).Resize(5, 3).Value = w
　　End With
　　Application.ScreenUpdating = True
End Sub

で、唐突な結論ですが、 ■ReplaceメソッドとEvents制御 の時と同じように、
イベントプロシージャがなくても、[EnableEvents プロパティ]の制御は必須のようですね。
2007では顕著な差が出ます。

Sub try3()
　　Const x = 100
　　Const y = 1000
　　Dim i As Long
　　Dim v, w(4, 2)

　　Application.ScreenUpdating = False
　　With Workbooks.Add(xlWBATWorksheet)
　　　　With .Worksheets(1).Cells(1).Resize(y, x)
　　　　　　.Value = "abcde"
　　　　　　w(0, 1) = "Events=True"
　　　　　　w(0, 2) = "Events=False"
　　　　　　w(1, 0) = "v = .Value"
　　　　　　w(2, 0) = ".ClearContents"
　　　　　　w(3, 0) = ".Value = v"
　　　　　　w(4, 0) = "計"
　　　　　　For i = 1 To 2
　　　　　　　　Call timechk(timeGetTime)
　　　　　　　　v = .Value
　　　　　　　　w(1, i) = timechk(timeGetTime)
　　　　　　　　.ClearContents
　　　　　　　　w(2, i) = timechk(timeGetTime)
　　　　　　　　.Value = v
　　　　　　　　w(3, i) = timechk(timeGetTime)
　　　　　　　　Application.EnableEvents = False
　　　　　　Next
　　　　　　Application.EnableEvents = True
　　　　End With
　　　　w(4, 1) = w(1, 1) + w(2, 1) + w(3, 1)
　　　　w(4, 2) = w(1, 2) + w(2, 2) + w(3, 2)
　　　　.Sheets.Add.Cells(1).Resize(5, 3).Value = w
　　End With
　　Application.ScreenUpdating = True
End Sub

ちなみに[Vista/2000]でも効果あり。



（2008.12.15追記）
またまた懺悔ですorz
>イベントプロシージャがなくても、[EnableEvents プロパティ]の制御は必須のようですね。
>2007では顕著な差が出ます。
今日現在、上記のような事実は確認できません。
結論として、検証誤りと言われても仕方ありません。ごめんなさい。

#検証時、イベントプロシージャがあったのではないかと思われるかもしれませんが、それは無いです。
#が、2007をインストールし直しても再現しなかったので根拠が無くなりました（泣

■数式を行列入れ替えて貼り付け。

FAQなネタよりもちょっと捻ったテーマに飛びつく歪んだ性格のせいか、ネタに枯渇してきました XD
Q&A掲示板で遭遇したネタの中であまり見かけないテーマを取り上げても、『そんなニーズあんのか？』っていう感想を持たれる方が多いでしょう。
ごめんなさい。

...という事で、いちおう先に謝ったので書きますね :D
セル範囲をコピーして、[形式を選択して貼り付け]の中に[行列を入れ替える]というのがあります。
[PasteSpecial メソッド]の引数 Transpose です。
これが、『数式だけを行列入れ替えてコピーしたい』というニーズに応えてくれないようです。
つまり、

これを

こうしたい、と...まさに『そんなニーズあんのか？』...ですね

一般操作で[置換]機能を使ってできなくもないです。マクロで表現すると

Sub Macro1()
　　With Cells(1).CurrentRegion
　　　　.Replace What:="=", _
　　　　　　　　 Replacement:="|=", _
　　　　　　　　 LookAt:=xlPart, _
　　　　　　　　 MatchCase:=False
　　　　.Copy
　　　　.Offset(, .Columns.Count).Cells(1).PasteSpecial Transpose:=True
　　　　.EntireColumn.Delete
　　End With
　　Application.CutCopyMode = False
　　Cells(1).CurrentRegion.Replace What:="|=", _
　　　　　　　　　　　　　　　　　 Replacement:="=", _
　　　　　　　　　　　　　　　　　 LookAt:=xlPart, _
　　　　　　　　　　　　　　　　　 MatchCase:=False
End Sub

こんな感じ。

[Value プロパティ]ではなく[Formula プロパティ]を使って、配列に数式を取り込むと比較的簡単にできます。

Sub try()
　　Dim v

　　With Cells(1).CurrentRegion
　　　　v = WorksheetFunction.Transpose(.Formula)
　　　　.ClearContents
　　　　.Cells(1).Resize(UBound(v, 1), UBound(v, 2)).Formula = v
　　End With
End Sub

（当然ですが256行|列まで）

でもきっと、
「どっかにそんなコード書いたなぁ、どこだったっけ...？」
と探すより手作業でやったほうが早い。という場面が多いでしょう。ぃや、そんな場面に出くわす事さえないかもしれません。
...ぷち＆非実用度★★★★☆なTipでしたorz