■損益分岐点グラフ

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

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

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

■Excel2007で無くなったプロパティなどなど。

私のメイン環境であるExcel2000では [Application.MemoryUsedプロパティ]は普通に使えるのだが、（使えるが滅多に使わないけど：笑）2003で非表示メンバになってた。
それも知らなかったのだが、2007では無くなってた :-(
（MemoryFree や MemoryTotal もです）

確かに Application.MemoryUsed をgoogle検索してもweb全体で763件しかhitしないからなぁ...（そのうち１件は半角チルダ？：笑）
ぃや、そういう問題じゃなく？ Application.DoubleClick メソッドは538件だけど健在だし。

そんな事もあって、2007で追加されたプロパティやメソッドの一覧とか、逆に無くなったプロパティなどの一覧とかがまとめられたwebページがないか探してみた。
やっぱり『MSDN ライブラリ』よねぇ...と探したけど...

無い。



...でも
New Objects, Collections, and Enumerations
Object Model Changes Since Microsoft Office 2000
本家にはあるよぅだ。早く翻訳してほしー

■魔方陣というか、

一定の法則で数値が配置されていれば数式で可能ってことなのね...orz

Sub try()
　　Const n As Long = 7

　　Range("A1").Resize(n, n).Formula _
　　　　= "=MOD(IF(ROW()=1," _
　　　　& "(COLUMN()-INT(" & n & "/2)-1)*(" & n & "+2)+1+" _
　　　　& "(COLUMN()<INT(" & n & "/2)+1)*" & n & "," _
　　　　& "OFFSET(A1,-1,)+1+(MOD(OFFSET(A1,-1,)," & n & ")>0)*" & n _
　　　　& ")-1," & n & "^2)+1"
End Sub

■魔方陣であそんでみた。

...というか一人反省会。またもや試行錯誤な日々なのである。


こんな感じの7x7の魔方陣をVBAで書く、という課題にレスしてしまった。

オーソドックスに解くと

Sub try1()
　　Const n As Long = 7
　　Dim x As Long
　　Dim y As Long
　　Dim i As Long

　　x = n ¥ 2 + 1
　　For i = 1 To n ^ 2
　　　　If i Mod n <> 1 Then
　　　　　　If x = n Then
　　　　　　　　x = 1
　　　　　　Else
　　　　　　　　x = x + 1
　　　　　　End If
　　　　　　If y = 1 Then
　　　　　　　　y = n
　　　　　　Else
　　　　　　　　y = y - 1
　　　　　　End If
　　　　Else
　　　　　　If y = n Then
　　　　　　　　y = 1
　　　　　　Else
　　　　　　　　y = y + 1
　　　　　　End If
　　　　End If
　　　　Cells(y, x).Value = i
　　Next
End Sub

こんなん？

IIF関数を使えばちょっと見通しが良くなる。

Sub try2()
　　Const n As Long = 7
　　Dim x As Long
　　Dim y As Long
　　Dim i As Long

　　x = n ¥ 2 + 1
　　For i = 1 To n ^ 2
　　　　If i Mod n <> 1 Then
　　　　　　x = IIf(x = n, 1, x + 1)
　　　　　　y = IIf(y = 1, n, y - 1)
　　　　Else
　　　　　　y = IIf(y = n, 1, y + 1)
　　　　End If
　　　　Cells(y, x).Value = i
　　Next
End Sub

ここで捻くれたのがいけなかったようだ :-(

Sub try3()
　　Dim n As Long
　　Dim x As Long
　　Dim y As Long
　　Dim i As Long

　　n = Application.InputBox("num", Type:=1)
　　If n < 3 Or n > 255 Or n Mod 2 = 0 Then Exit Sub
　　ReDim v(1 To n, 1 To n) As Long
　　ReDim z(1 To n ^ 2, 1 To 5) As Long
　　x = n ¥ 2 + 1
　　y = 1
　　For i = 1 To n ^ 2
　　　　If i Mod n <> 1 Then
　　　　　　x = IIf(x = n, 1, x + 1)
　　　　　　y = IIf(y = n, 1, y + 1)
　　　　Else
　　　　　　y = IIf(y = 1, n, y - 1)
　　　　End If
　　　　v(y, x) = i
　　　　z(i, 1) = i
　　　　z(i, 2) = (i - 1) ¥ n + 1
　　　　z(i, 3) = (i - 1) Mod n + 1
　　　　z(i, 4) = y
　　　　z(i, 5) = x
　　Next
　　With Cells(1)
　　　　.CurrentRegion.ClearContents
　　　　.Resize(n, n).Value = v
　　　　.Offset(, n + 1).Resize(n ^ 2, 5).Value = z
　　End With
End Sub

こんなので i のインクリメントとの関係からIF分岐せずに x,y を導き出せるか探ってみる。
try2では y（行）が負方向に遷移するので面倒。なのでtry3は上下反転させてちょっと悩んでみた。



で、出てきたレスがこれ。

Sub try()
　　Const n As Long = 7
　　Dim v(1 To n, 1 To n) As Long
　　Dim w As Long
　　Dim x As Long
　　Dim y As Long
　　Dim i As Long
　　Dim j As Long

　　w = 0
　　For i = 1 To n
　　　　For j = 1 To n
　　　　　　x = (j + i * (n - 1) + n ¥ 2) Mod n + 1
　　　　　　y = (j + i * (n - 2)) Mod n + 1
　　　　　　w = w + 1
　　　　　　v(y, x) = w
　　　　Next
　　Next
　　Range("A1").Resize(n, n).Value = v
End Sub

#いぢわるなレスである。
#経緯を省いてるからきっとわけわかんないよね...

さて、ここから反省なのだが、
Mod関数を使ってるくせに２重Loopって無駄？...と気づき

Sub try4()
　　Const n As Long = 7
　　Dim x As Long
　　Dim y As Long
　　Dim i As Long
　　Dim j As Long

　　For i = 1 To n ^ 2
　　　　j = (i - 1) ¥ n
　　　　x = (i + (n ¥ 2) + j * (n - 1) - 1) Mod n + 1
　　　　y = (i + (n - 1) + j * (n - 2) - 1) Mod n + 1
　　　　Cells(n + 1 - y, x).Value = i
　　Next
End Sub

こんな感じにしてみた。

どうせわかりにくいんだからついで（？）に

Sub try5()
　　Const n As Long = 7
　　Dim i As Long

　　For i = 1 To n ^ 2
　　　　Cells(n - (i + (n - 1) + ((i - 1) ¥ n) * (n - 2) - 1) Mod n, _
　　　　　　　　　(i + (n ¥ 2) + ((i - 1) ¥ n) * (n - 1) - 1) Mod n + 1).Value = i
　　Next
End Sub

ぃや、ごめんなさい、お遊びですorz

■2007 オートシェイプ マクロ記録

Excel2007では、図形オブジェクトの操作はマクロに記録されなくなりました。

[Excel 2007 新しい図形と図形書式と図形の効果を記録することができません。]
「the 2007 Microsoft Office system ― マクロの互換性について」

Shapes については機能が色々と強化されたようですので、そのせいかもしれませんが、マクロ記録できないのはちょっと不便です。そのうち追加されるのでしょうかねぇ...？
以前のバージョンを持っている方は、そちらで記録して参考にする事ができますからいいでしょうけど、2007しか持ってない方は、例えば

Dim sp As Shape
sp.

...などとし、表示される[プロパティ/メソッドの一覧]を参考に、ヘルプやオブジェクトブラウザを駆使してコーディングしていく事になるようです。
他に、テキストボックス程度に限っての話ですが、ビギナーの方の場合、代替的にフォームコントロールの操作を記録して、それを参考にすると良いかもしれません。
[開発]タブの[コントロール]-[挿入]にある[フォームコントロール]です。

Sub Macro1()
'
' Macro1 Macro
'

'
　　ActiveSheet.Buttons.Add(51.75, 28.5, 93, 25.5).Select
　　With Selection
　　　　.HorizontalAlignment = xlCenter
　　　　.VerticalAlignment = xlCenter
　　　　.ReadingOrder = xlContext
　　　　.Orientation = xlHorizontal
　　　　.AutoSize = True
　　　　.AddIndent = False
　　End With
　　Selection.ShapeRange.LockAspectRatio = msoFalse
　　Selection.ShapeRange.Height = 28.5
　　Selection.ShapeRange.Width = 105#
　　With Selection
　　　　.Locked = False
　　　　.LockedText = False
　　End With
　　With Selection
　　　　.Placement = xlFreeFloating
　　　　.PrintObject = True
　　End With
　　Selection.ShapeRange.TextFrame.MarginLeft = 7.09
　　Selection.ShapeRange.TextFrame.MarginRight = 7.09
　　Selection.ShapeRange.TextFrame.MarginTop = 3.69
　　Selection.ShapeRange.TextFrame.MarginBottom = 3.69
　　Selection.ShapeRange.AlternativeText = "a"
　　Selection.Characters.Text = "ボタン 1"
　　With Selection.Characters(Start:=1, Length:=5).Font
　　　　.Name = "ＭＳ Ｐゴシック"
　　　　.FontStyle = "標準"
　　　　.Size = 11
　　　　.Strikethrough = False
　　　　.Superscript = False
　　　　.Subscript = False
　　　　.OutlineFont = False
　　　　.Shadow = False
　　　　.Underline = xlUnderlineStyleNone
　　　　.ThemeColor = 2 '※
　　　　.TintAndShade = 0 '※
　　　　.ThemeFont = xlThemeFontNone '※
　　End With
End Sub

こんな感じで記録されますので、
ActiveSheet.Buttons.Add(......を
ActiveSheet.TextBoxes.Add(......などのように修正したりする事で、雰囲気くらいは掴めるかも :-)

#記録コードそのものなので、そのままではエラーになるプロパティもあります。(※)