t-hom’s diary

主にVBAネタを扱っているブログ…とも言えなくなってきたこの頃。

コード共通化のデメリット

プログラミングが上達すると、コードの共通部分をプロシージャに切り出すことを覚える。
コードを共通化すれば、共通部分に変更が発生した場合に、修正は一か所で済むので効率的だとされる。

はたして本当にそうだろうか?
私もつい最近まで、コードの共通化は善だと信じていた。

しかし、最近いくつかの機能を備えたプログラムを書く機会があり、この考えに疑念を抱くようになった。

例えば下図のように機能Aと機能Bがそれぞれ別のモジュールに存在し、それぞれ3つのプロシージャで構成されているとしよう。
f:id:t-hom:20180614184636p:plain

そして、ProcA-2とProcB-2が多くの点で共通しており、うまくすればひとつのプロシージャに纏めることができる状況を想像してみて欲しい。

実際にまとめるとこのようになる。
f:id:t-hom:20180614190856p:plain

以前の私なら、このコードは変更に強くなったと考えていた。
しかし実際にこのような状況を経験してみて、その考えは浅はかだったと反省することになった。

例えば機能Aを変更したいとき、それに合わせて共通プロシージャProcAB-2も変更する必要が生じたとする。
しかしProcAB-2を変更するには、機能Bに悪影響が無いよう慎重に整合性を保つ必要が出てくる。

複数の機能から依存された共通プロシージャは、おいそれと変更できなくなる。
また、これまで単一モジュールで完結していた機能が複数モジュールにまたがることで、モジュールの独立性が弱まり、別プロジェクトへの移植も困難になる。

DLL地獄というのを聞いたことがあるだろうか。様々なアプリケーションが共通DLLに依存しており、ソフトウェアによって依存しているDLLバージョンが異なることで発生するトラブルである。コードの共通化はまさにこれと同じトラブルを招く危険性がある。

私は最近、過度のコード共通化でプロジェクトのあちこちに依存が発生し、そのVBプロジェクトを破綻させてしまった。

今、最初からやり直しているが、心がけていることは極力モジュールの単体完結性を維持することである。ひとつの機能をうまく成し遂げるためにモジュールを作る。モジュール間でコードの重複があっても気にしないこと。それは必要な冗長性だ。

ここまでコード共通化のデメリットを書いてきたが、もちろん正しい共通化にはメリットがある。
私が問題だと思うのは、共通化は善であり、共通化可能だという単純な理由で依存性やプロシージャの独立性を考慮せずに共通化するケースである。
真に汎用的なプロシージャが、たまたま機能Aと機能Bから参照される場合は問題ないと思う。

VBA モジュールのプロシージャは呼び出し順に書く

VBAでは互いに関連するプロシージャをひとつのモジュールに纏めることが多い。
このとき、呼び出す側と呼ばれる側のどちらを先に書けば良いだろうか。

以前の私の考えでは、例えばProc1がProc2を呼び出すとき、呼ばれる側を先に定義しておくという意味で先に書くことがあった。

Sub Proc2()
    MsgBox "Hello"
End Sub

Sub Proc1()
    Call Proc2
End Sub

(ただし、VBAの場合はどの順で書いても動くので、過去のコードで厳密にこの原則を守っていたわけではない)

最近Clean Codeという書籍を読んで、完全に考えが変わった。

Clean Code アジャイルソフトウェア達人の技

Clean Code アジャイルソフトウェア達人の技

※書籍のサンプルコードはJavaで書かれてますが考え方はすべての言語に共通します。

Clean Codeによると、呼び出し側を上に、呼ばれる側が下になるのが望ましいとのこと。
たしかに、物事の説明の流れからしても概要→詳細となるのでコードにおいても粒度の大きいものを先頭に持ってくるというのは理にかなっている。
そして、可能な限り呼ばれる方のプロシージャは、呼び出すプロシージャの直下に置くこと。

マクロが複雑化し、プロシージャが増えれば増えるほど、プロシージャ同士の垂直方向の距離に気を配らないと読みづらくなり、理解に支障をきたす。

例えば次のプロシージャ群をひとつのモジュールに纏めるとする。

Sub Proc1()
    Debug.Print "Proc1"
    Call Proc2
    Call Proc3
    Call Proc4
End Sub
Sub Proc2()
    Debug.Print "Proc2"
    Call Proc5
End Sub
Sub Proc3()
    Debug.Print "Proc3"
    Call Proc6
End Sub
Sub Proc4()
    Debug.Print "Proc4"
    Call Proc7
End Sub
Sub Proc5()
    Debug.Print "Proc5"
End Sub
Sub Proc6()
    Debug.Print "Proc6"
End Sub
Sub Proc7()
    Debug.Print "Proc7"
End Sub

呼び出し関係を図で表すと、こうなる。
f:id:t-hom:20180614000352p:plain

冒頭に述べた「呼ばれる側を先に定義しておく」とは矛盾するが、私は階層順という考えも取り入れていた。
f:id:t-hom:20180614000627p:plain

まさに先ほどのコードは階層順に並べたものだ。

しかしClean Codeを読んで以来、プロシージャは以下のように呼び出し順に並べるのが最も理解しやすいと考えるようになった。
f:id:t-hom:20180614001235p:plain

改善したコードがこちら。

Sub Proc1()
    Debug.Print "Proc1"
    Call Proc2
    Call Proc3
    Call Proc4
End Sub
Sub Proc2()
    Debug.Print "Proc2"
    Call Proc5
End Sub
Sub Proc5()
    Debug.Print "Proc5"
End Sub
Sub Proc3()
    Debug.Print "Proc3"
    Call Proc6
End Sub
Sub Proc6()
    Debug.Print "Proc6"
End Sub
Sub Proc4()
    Debug.Print "Proc4"
    Call Proc7
End Sub
Sub Proc7()
    Debug.Print "Proc7"
End Sub

最近の例では、自動スクリーンショットを取るためのマクロでプロシージャの並び替えを行った。
呼び出しマップ関係図はこちら。
f:id:t-hom:20180613234407p:plain

並び替えのビフォーアフターはこのようになった。
Before

Private Sub clearClipboard()
Private Sub animateCaption()
Public Sub StartAutoScrap()
Public Sub StopAutoScrap()
Public Sub OnTimeScrap(Optional ByRef void = Empty)
Private Sub popUpWindow()
Private Property Get prevWindow() As Long
Private Property Get lowestShapeEdge() As Single

After

Public Sub StartAutoScrap()
Public Sub StopAutoScrap()
Public Sub OnTimeScrap(Optional ByRef void = Empty)
Private Sub animateCaption()
Private Property Get lowestShapeEdge() As Single
Private Sub popUpWindow()
Private Property Get prevWindow() As Long
Private Sub clearClipboard()

OnTimeScrapは4つのプロシージャを呼び出しているが、コードに登場する順に並べた。
f:id:t-hom:20180614003552p:plain

呼び出し関係と並び順だけ取り出して図示すると、こんな感じ。
Before
f:id:t-hom:20180614002623p:plain

After
f:id:t-hom:20180614002644p:plain

変更後は呼び出しの矢印が常に右に伸びていてわかりやすい。
図中のBだけ独立しているのが気になる方がいると思う。
このBはStopAutoScrapを表しており、StartAutoScrapと機能的に対になるマクロなのでStartAutoScrapのすぐ下に置いている。

呼び出しの原則に従うと、こうするか、

Public Sub StopAutoScrap()
Public Sub StartAutoScrap()
Public Sub OnTimeScrap(Optional ByRef void = Empty)
Private Sub animateCaption()
Private Property Get lowestShapeEdge() As Single
Private Sub popUpWindow()
Private Property Get prevWindow() As Long
Private Sub clearClipboard()

こうすることになるけれど、

Public Sub StartAutoScrap()
Public Sub OnTimeScrap(Optional ByRef void = Empty)
Private Sub animateCaption()
Private Property Get lowestShapeEdge() As Single
Private Sub popUpWindow()
Private Property Get prevWindow() As Long
Private Sub clearClipboard()
Public Sub StopAutoScrap()

どちらも微妙なので、今回は呼び出し関係よりも機能的な相対関係を優先した。

以上

VBA 専用ツールを使わないカスタムリボン作成チュートリアル

今回はマクロを実行できるリボン作成方法の紹介。
Excel2013をターゲットにしている。2010でもほぼこの通りにできるが、微妙にrelsに指定するURLが違ったりするのでうまくいかない場合は他のサイトを合わせて確認することをお勧めする。

ブックの準備

新規ブックを作成し、標準モジュールを挿入してオブジェクト名をRibbonに変更する。
f:id:t-hom:20180613023700p:plain

標準モジュールRibbonに次のコードを挿入する。

Private Const RIBBON_TABNAME = "MyOriginalRibbon"
Sub Ribbon_onLoad(Ribbon As IRibbonUI)
    Ribbon.ActivateTab RIBBON_TABNAME
End Sub

Sub RibbonMacros(control As IRibbonControl)
    Application.Run control.Tag, control
End Sub

Private Sub Dummy(control As IRibbonControl)
    Application.Run control.ID
End Sub

この時、RIBBON_TABNAMEの値は任意だが、リボンの目的に沿った適切な名前にすると良い。

一旦ここまででブックを保存して閉じる。
今回はBook1.xlsmとした。

リボン用XMLの作成

保存したBook1のファイル名に拡張子「xlsm」が表示されていることを確認する。
f:id:t-hom:20180613024332p:plain
表示されてなければGoogleで「拡張子 表示」等と検索して設定を済ませる。

ファイル名に拡張子.zipを追加する。
f:id:t-hom:20180613024511p:plain

警告が表示されるが、「はい」で続行する。

Book1.xlsm.zipを右クリックし、メニューから、プログラムから開くをクリック。
f:id:t-hom:20180613024656p:plain

エクスプローラーが選択された状態でOKをクリック。
f:id:t-hom:20180613024748p:plain

エクスプローラーで中身が確認できるので、_relsフォルダを開く。
f:id:t-hom:20180613033818p:plain

中に.relsというファイルが入っている。
この後この.relsを編集するが、zipファイル内で直接編集はできないので一旦外に出す。
具体的には、.relsをデスクトップ等の任意の場所へドラッグ&ドロップでコピーすると良い。
f:id:t-hom:20180613033724p:plain

この.relsをメモ帳で開く。
右端で折り返しを外しておくと良い。
f:id:t-hom:20180613025620p:plain

折り返しを外すと随分と横長の行になるので、><を見つけて間で改行する。
f:id:t-hom:20180613025706p:plain

こんな感じになる。
f:id:t-hom:20180613025828p:plain

最後の</Relationship>の手前の行に次の一行を追記する。

<Relationship Id="customUI" Type="http://schemas.microsoft.com/office/2006/relationships/ui/extensibility" Target="customUI/customUI.xml"/>

f:id:t-hom:20180613030154p:plain

上書き保存して閉じる。

保存した.relsをBook1.xlsm.zipの元の位置にコピーする。
f:id:t-hom:20180614011112p:plain

置き換えして良いかどうかの確認が表示されるので、置き換えする方を選択する。
f:id:t-hom:20180613031141p:plain

CustomUI.xmlの作成

メモ帳を新規で開き、次のコードを張り付ける。

<?xml version="1.0" encoding="utf-8"?>
<customUI onLoad="Ribbon_onLoad" xmlns="http://schemas.microsoft.com/office/2006/01/customui">
<ribbon>
<tabs>
<tab id="MyOriginalRibbon" label="マイリボン" insertBeforeMso="TabHome">

<group id="GroupA" label="グループA">
	<button id="R_Macro1"
	imageMso="HappyFace"
	size="large"
	label="マクロ1"
	onAction="RibbonMacros"
	tag="Dummy"
	/>

	<button id="R_Macro2"
	imageMso="HappyFace"
	size="large"
	label="マクロ2"
	onAction="RibbonMacros"
	tag="Dummy"
	/>
</group>

<group id="GroupB" label="グループB">
	<button id="R_Macro3"
	imageMso="HappyFace"
	size="large"
	label="マクロ3"
	onAction="RibbonMacros"
	tag="Dummy"
	/>

	<button id="R_Macro4"
	imageMso="HappyFace"
	size="large"
	label="マクロ4"
	onAction="RibbonMacros"
	tag="Dummy"
	/>
</group>

</tab>
</tabs>
</ribbon>
</customUI>

ファイルメニューから名前をつけて保存するが、その際に文字コードUTF-8に、ファイルの種類はすべてのファイルを選択したうえで、CustomUI.xmlという名称で保存する。
f:id:t-hom:20180613032929p:plain

デスクトップ等にCustomUIという名前のフォルダを作り、そこにCustomUI.xmlを格納する。
f:id:t-hom:20180613033104p:plain

Book1.xlsm.zipをエクスプローラーで開き、そのトップ階層にCustomUIフォルダごとコピーする。
f:id:t-hom:20180613033531p:plain

Book1.xlsm.zipを開いているエクスプローラーを閉じ、ファイル名をBook1.xlsmに戻す。
f:id:t-hom:20180613034000p:plain
警告が出るが、続行する。

Excelを起動するとずらっとボタンが並んでいる。
コンテンツを有効化してボタンを押してみよう。
f:id:t-hom:20180613034143p:plain

すると、次のエラーが表示される。
f:id:t-hom:20180613034308p:plain

これは、ボタンに対応するマクロ「R_Macro1」を用意していない為だ。

標準モジュールRibbonに次のコードを追記する。

Private Sub R_Macro1()
    MsgBox "マクロ1が実行されました。"
End Sub

Private Sub R_Macro2()
    MsgBox "マクロ2が実行されました。"
End Sub

Private Sub R_Macro3()
    MsgBox "マクロ3が実行されました。"
End Sub

Private Sub R_Macro4()
    MsgBox "マクロ4が実行されました。"
End Sub

これでもう一度ボタンを押すと、ボタンに対応したマクロが実行される。
f:id:t-hom:20180613034606p:plain

CustomUIの説明

冒頭部分はそれぞれコードとリボンの表示に次のように対応している。
f:id:t-hom:20180613035709p:plain

insertBeforeMso="TabHome"は省略することができ、省略した場合は最後尾のタブになる。

中身のグループとボタンのうち、リボンの表示に関係する部分を赤字で示した。
f:id:t-hom:20180613040602p:plain

次に、実行コードに関係する部分を赤字で示した。
f:id:t-hom:20180613041005p:plain

ボタンが押されると、まずonActionに指定したプロシージャ(RibbonMacros)が呼ばれる。
このとき引数としてリボンのボタンオブジェクトがRibbonMacrosに渡される。

RibbonMacrosはApplication.Runでボタンオブジェクトに指定したタグ("Dummy")に格納された名称のプロシージャを実行する。
このとき引数として、受け取ったボタンオブジェクトをDummyプロシージャに引き渡す。

DummyプロシージャはApplication.Runで受け取ったボタンオブジェクトのID("R_Macro1")に格納された名称のプロシージャを実行する。

私の場合は普段からこのように3段構えでボタンマクロを実行させる仕組みを構築している。
いきなりonActionに実際のマクロ名を書いても良いのだが、そうしないのは三段構えにすると柔軟性が高まる為だ。
タグにはDummyを指定しているが、マクロ1とマクロ2で共通の前処理があった場合は次の用に変更する。

CustomUI.xml

<group id="GroupA" label="グループA">
	<button id="R_Macro1"
	imageMso="HappyFace"
	size="large"
	label="マクロ1"
	onAction="RibbonMacros"
	tag="CommonProcA"
	/>

	<button id="R_Macro2"
	imageMso="HappyFace"
	size="large"
	label="マクロ2"
	onAction="RibbonMacros"
	tag="CommonProcA"
	/>
</group>

VBAProject.Ribbon

Sub RibbonMacros(control As IRibbonControl)
    Application.Run control.Tag, control
End Sub

Private Sub Dummy(control As IRibbonControl)
    Application.Run control.ID
End Sub

Private Sub CommonProcA(control As IRibbonControl)
    MsgBox "共通処理A"
    Application.Run control.ID
End Sub

Private Sub R_Macro1()
    MsgBox "マクロ1が実行されました。"
End Sub

Private Sub R_Macro2()
    MsgBox "マクロ2が実行されました。"
End Sub

すると、マクロ1ボタンとマクロ2ボタンの共通処理をCommonProcAに纏めることができる。
ボタンクリック時に最初に呼ばれるコードをRibbonMacrosに纏めることで、各処理をPrivateにできることも大きい。
リボン側に公開するためにPublicにするのはRibbonMacrosだけで済むのだ。

実際にはR_Macro1の中身は別のモジュールに作成し、R_Macro1はその別モジュールのプロシージャを単に呼び出すだけという作りにすることが多い。
Ribbonモジュールはリボンの処理に専念させる。

参考:ImageMSOのアイコンを探す方法

HappyFace以外のアイコンはこちらで探すと良い。
www.ka-net.org

Bitmapとして一括保存する方法はこちら。
thom.hateblo.jp

オリジナルアイコンをファイルに埋め込んでリボンのボタンに表示させる方法

まずpng画像を用意する。32x32の背景透過アイコンがベストだが、自動的にリサイズされるので細かいつぶれが気にならなければ何でも良い。
適当なものが無い場合、オートシェイプでアイコンを作ってグループ化し、右クリックメニューから図として保存を選択するとpngで保存できる。
f:id:t-hom:20180613051452p:plain

デスクトップ等にimagesというフォルダを作り、用意したpng画像を入れておく。
f:id:t-hom:20180613051622p:plain

次にメモ帳を開き、次のコードを張り付ける。

<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<Relationships xmlns="http://schemas.openxmlformats.org/package/2006/relationships">
<Relationship Id="mySample1" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/image" Target="images/Sample.png"/>
</Relationships>

CustomUI.xml.relsという名前で、UTF-8を選択して保存する。
そしてデスクトップ等に_relsというフォルダを作り、CustomUI.xml.relsを格納する。
f:id:t-hom:20180613052033p:plain

Book1.xlsmをBook1.xlsm.zipに変更し、エクスプローラーで開き、CustomUIフォルダを開いて_relsとimagesフォルダをコピーする。
f:id:t-hom:20180613052341p:plain

CustomUI.xmlを一旦デスクトップにコピーし、imageMso="HappyFace"の部分をimage="mySample"に書き換えてから再度zipのCustomUIフォルダに戻す。
Msoが取れて単にimageになるので、ここ間違えないよう注意。

次に、zipの直下にある[Content_Types].xmlをデスクトップにコピーしてメモ帳で開く。

<Default Extension="rels"という表記を探す。
f:id:t-hom:20180613052733p:plain

見つかったらその手前に、<Default Extension="png" ContentType="image/png"/>を挿入する。
f:id:t-hom:20180613052910p:plain

上書き保存し、zipの直下に戻す。

ファイル名をBook1.xlsmに戻し、ファイルを開く。

このように、オリジナルのアイコンが埋め込まれる。
f:id:t-hom:20180613053144p:plain

ImageMSOはなかなか思い通りのアイコンが無かったり、探すのが大変だったり、Excelのバージョンによって表示が異なったりするので、絵心がある方は自分で描くなり、ロイヤリティーフリー素材を活用するなりして素敵なアイコンを用意すると魅力的なツールになると思う。

VBA バグの回避コードは別プロシージャに分離し、説明的な名前をつけ、懇切丁寧にコメントする。

プログラミングでどうにもならないバグに出会ったとき、そのバグを回避するコードを書くことになる。
バグの回避コードというのは厄介で、単体で読んでも一見何をやっているのかさっぱり分からないことが多い。

これをメインの処理コードに混ぜ込むと、メイン処理の理解を難しくさせる。
従って、バグ回避コードは短いものであっても別プロシージャに分離するのが望ましい。

また、プロシージャ名はそのプロシージャの機能を説明する簡潔な名前であることが望ましいが、バグの回避用プロシージャは簡潔さを犠牲にしてでも説明的な名称にこだわりたい。

以下、前回の記事で紹介したバグ回避用のプロシージャである。
長大な名称になっているが、「バグ 回避 for 数値書式コピー失敗」なので目的が一目瞭然。

Sub BugAvoidanceForNumberFormatCopyFail()
    Dim r As Range: Set r = ThisWorkbook.ActiveSheet.Cells(1, 1)
    Do Until r.Value = "" And r.Offset(1, 0).Value = ""
        Set r = r.Offset(1, 0)
    Loop
    r.Value = Date
    r.NumberFormat = "hh:mm:ss"
    r.Copy r.Offset(1, 0)
    Range(r, r.Offset(1, 0)).ClearContents
'Rem Reproducible bug code are below.
'Sub NumberFormatCopyFail
'    With ThisWorkbook.Sheets.Add
'        .Range("B1").Value = "22:00"
'        .Range("A1:B1").Copy
'        .Range("A2").Select
'    End With
'    ActiveSheet.Paste
'    Application.CutCopyMode = False
'End Sub
End Sub

最初はBugFixにしてたけど根本解決じゃないしなぁ。。ということでAvoidance(回避)とした。
「Workaround_NumberFormatCopyFailIssue」という名前でも良かったかな。

それから懇切丁寧にコメントする。
コードの挙動ではなく、目的をコメントすることが肝心。挙動はコードを見れば分かるし、少々複雑でもステップ実行すれば分かるが、それをもって一体何がしたいのかは説明がないと分からない。

前回工夫したのはこの部分。

'Rem Reproducible bug code are below.
'Sub NumberFormatCopyFail
'    With ThisWorkbook.Sheets.Add
'        .Range("B1").Value = "22:00"
'        .Range("A1:B1").Copy
'        .Range("A2").Select
'    End With
'    ActiveSheet.Paste
'    Application.CutCopyMode = False
'End Sub

これはパッと見、使わなくなった古いコードをコメントアウトしているだけに見えるけど、私はそれはしない主義。
実は日本語でつらつら説明するのが面倒だったので、バグの再現マクロをそのまま張り付けてコメント化するという新たな試みだった。
Reproducible bug code are below(再現可能なバグコードは以下)となんとなく気分で英語で書いてみたので苦手な方は単なる不要コードのコメントアウトに見えたかも。ごめん。。

以上。

VBA バグ?Number Formatがコピーされない事象

作成中のマクロでバグっぽい事象が確認されたのでメモ。
発生した環境はExcel 2013 32bit on Windows 10 Home 64bit。

マクロというよりは、手でやっても同じことになるので手作業の方を先に紹介。

  1. 新規シートを挿入する。
  2. B1セルに時刻を入力する。
  3. A1:B2の2セルを範囲選択してCtrl+Cでコピー
  4. A2セルに張り付ける。

f:id:t-hom:20180611221313p:plain

すると、なぜかシリアル値になる。
f:id:t-hom:20180611221729p:plain

暫くは何度やってもこの事象が再現するのだが、一度B2セル単体でコピーすればもうそのシートでは発生しなくなる。

再現マクロがこちら。

Sub IGuessItIsABug()
    Dim sh As Worksheet
    Set sh = Sheets.Add
    sh.Range("B1").Value = "22:00"
    sh.Range("A1:B1").Copy
    sh.Range("A2").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
End Sub

そして、このような処理を行うとバグが回避され、以降そのシートでは再現しなくなる。

Sub WorkAroundForTheIssue()
    Dim sh As Worksheet
    Set sh = Sheets.Add
    sh.Range("B1").Value = "22:00"

    '予めB2に個別に張り付けておく
    sh.Range("B1").Copy
    sh.Range("B2").Select
    ActiveSheet.Paste

    'A2に貼り付ける。
    sh.Range("A1:B1").Copy
    sh.Range("A2").Select
    ActiveSheet.Paste
    
    'A4に張り付けても事象は発生しなくなっている。
    sh.Range("A1:B1").Copy
    sh.Range("A4").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    
    '以降、このシートでは同事象は発生しなくなる。
    '別のセルでも同じように、成功する。
End Sub

ちなみにコピー範囲の先頭にNumberFormatがある場合は再現しない。

Sub NoBugPattern()
    Dim sh As Worksheet
    Set sh = Sheets.Add
    sh.Range("A1").Value = "22:00"
    sh.Range("A1:B1").Copy
    sh.Range("A2").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
End Sub

なにこれ。

追記

Twitterに事象を投げたところ羽毛田さん(サイト)が検証してくれたが、やはりバグのようだ。

とりあえずActiveSheetに対するBug回避用のコードを追記。

Sub BugAvoidanceForNumberFormatCopyFail()
    Dim r As Range: Set r = ThisWorkbook.ActiveSheet.Cells(1, 1)
    Do Until r.Value = "" And r.Offset(1, 0).Value = ""
        Set r = r.Offset(1, 0)
    Loop
    r.Value = Date
    r.NumberFormat = "hh:mm:ss"
    r.Copy r.Offset(1, 0)
    Range(r, r.Offset(1, 0)).ClearContents
'Rem Reproducible bug code are below.
'Sub NumberFormatCopyFail
'    With ThisWorkbook.Sheets.Add
'        .Range("B1").Value = "22:00"
'        .Range("A1:B1").Copy
'        .Range("A2").Select
'    End With
'    ActiveSheet.Paste
'    Application.CutCopyMode = False
'End Sub
End Sub

御礼に宣伝

関数は「使える順」に極めよう! Excel 最高の学び方 (できるビジネス)

関数は「使える順」に極めよう! Excel 最高の学び方 (できるビジネス)

VBA 角丸四角形の角の丸めサイズを統一するマクロ(Excel・PowePoint・Word対応)

角丸シェイプは普通の四角形に比べて柔らかい印象を与えるため、よく使用される。

しかし普通に配置すると、シェイプのサイズによって角丸のサイズも拡大・縮小するため、丸めサイズが不揃いで格好悪い。
f:id:t-hom:20180611080918p:plain

諦めているか、目視で微調整している方がほとんどだと思うけれど、できることなら数値指定でバシッと揃えたい。

ということでマクロの紹介。
角丸シェイプを複数選択した状態でこのマクロを実行すると、角の丸めサイズがきっちり揃う。

Sub AdjustRoundedRectangle()
    '選択中の角丸四角形の角を指定のサイズで丸めるマクロです。
    'ROUND_SIZEに5~20程度の整数を入れて試してみてください。
    'Excel・Word・PowerPontで使用できます。
    'ただしWordのキャンバス内のシェイプには対応していません。
    Const ROUND_SIZE = 10
    Dim sh As Shape
    '↓ActiveWindowはPowerPoint対応のために明示的に記載が必要。
    For Each sh In ActiveWindow.Selection.ShapeRange
        Dim shortEdge As Single
        '角丸のサイズは短辺を基に算出される為、shortEdgeを判定する。
        shortEdge = IIf(sh.Width < sh.Height, sh.Width, sh.Height)
        sh.Adjustments.Item(1) = ROUND_SIZE / shortEdge
    Next
End Sub

f:id:t-hom:20180611081528p:plain

丸めサイズの指定はROUND_SIZE定数を変更することで可能。

ただこのマクロは残念なことにWordのキャンバス内のシェイプには対応していない。
そこでキャンバス専用のマクロも用意した。

Sub AdjustRoundedRectangleForWordCanvas()
    '選択されたWordキャンバスに存在するすべての角丸四角形の角を
    '指定のサイズで丸めるマクロです。個別のシェイプ選択には対応していません。
    'ROUND_SIZEに5~20程度の整数を入れて試してみてください。
    Const ROUND_SIZE = 5
    Dim sh As Shape
    For Each sh In Selection.ShapeRange(1).CanvasItems
        If TypeName(sh) = "Shape" Then
            If sh.AutoShapeType = msoShapeRoundedRectangle Then
                Dim shortEdge As Single
                shortEdge = IIf(sh.Width < sh.Height, sh.Width, sh.Height)
                sh.Adjustments.Item(1) = ROUND_SIZE / shortEdge
            End If
        End If
    Next
End Sub

キャンバスに存在する角丸四角形を一つ選択して実行すると、そのキャンバス内のすべての角丸四角形が丸められる。
※これはキャンバス内の選択状態を拾う方法が分からなかった為。

以上

VBA オートシェイプの吹き出しの剣先を狙った位置に表示させるマクロ

オートシェイプを扱うマクロで特にややこしいのがAdjustmentsプロパティの調整だ。

Adjustmentsはシェイプを選択したときに黄色のハンドルが表示されるもので、ドラッグすることで調整ができる。
説明などでよく利用される吹き出しもAdjustmentsプロパティを持っている。
f:id:t-hom:20180610010746p:plain

さて、今回は吹き出しが狙った項目を指すように、剣先の位置を調整するマクロを紹介する。

今回作るもの

今回は吹き出しと四角形が適当に配置された状態から、吹き出しの剣先を四角形の左上隅に移動させるマクロを作成する。
f:id:t-hom:20180610011637p:plain

準備

実際のマクロではシェイプの挿入や特定もマクロで行うことが多いけれど、今回は説明用なので割愛し、シェイプの名前で特定することにする。

下図のように調べたいシェイプを選択した状態で、イミディエイトウィンドウに「?Selection.Name」と入力するとシェイプの名前が特定できる。
f:id:t-hom:20180610010541p:plain

今回は吹き出しと、適当な赤枠四角形を挿入して名前を調べておこう。

私の環境では吹き出しが「Rounded Rectangular Callout 26」、赤枠が「Rectangle 25」という名称だった。

コード

コードは次のとおり。

Sub SampleAdjustCalloutToTargetFrame()
    Dim callout As Shape
    Set callout = Sheet1.Shapes("Rounded Rectangular Callout 26")
    Dim frame As Shape
    Set frame = Sheet1.Shapes("Rectangle 25")

    Dim topDistance As Single: topDistance = frame.Top - callout.Top
    Dim leftDistance As Single: leftDistance = frame.Left - callout.Left
    callout.Adjustments.Item(1) = (leftDistance / callout.Width) - 0.5
    callout.Adjustments.Item(2) = (topDistance / callout.Height) - 0.5
End Sub

これを実行すると吹き出しの剣先が赤枠の左上隅に移動する。
f:id:t-hom:20180610012026p:plain

解説

肝となるのはAdjustmentsの挙動である。
AdjustmentsのItem(1)は横軸の位置を、Item(2)は縦軸の位置を表すが、この数値が共にゼロのとき、ちょうど吹き出しの中央に来る。

次のコードで試してみよう。

Sub SampleAdjustCalloutToZero()
    Dim callout As Shape
    Set callout = Sheet1.Shapes("Rounded Rectangular Callout 26")
    callout.Adjustments.Item(1) = 0
    callout.Adjustments.Item(2) = 0
End Sub

実行すると黄色いハンドルが中央に来る。
f:id:t-hom:20180610012448p:plain

このItem(1)は吹き出し本体の幅に対する比率で、正の数を指定すると剣先は右へ伸び、負の数を指定すると剣先は左へ延びる。
同様にItem(2)は高さに対する比率となっており、正の数を指定すると剣先は下へ伸び、負の数を指定すると剣先は上へ延びる。

次のコードはItem(1)のみ1にしたものである。

Sub SampleAdjustCalloutToOneZero()
    Dim callout As Shape
    Set callout = Sheet1.Shapes("Rounded Rectangular Callout 26")
    callout.Adjustments.Item(1) = 1
    callout.Adjustments.Item(2) = 0
End Sub

実行すると剣先はこのような位置にくる。
f:id:t-hom:20180610013310p:plain

これは吹き出し中央から右にちょうど本体1個分のサイズ移動したところが剣先になるということ。
f:id:t-hom:20180610013236p:plain

さて、ここから計算を容易にするため、シェイプのTopとLeftの値の位置に剣先を飛ばすよう補正をかけてみよう。

Sub SampleAdjustCalloutToTopLeft()
    Dim callout As Shape
    Set callout = Sheet1.Shapes("Rounded Rectangular Callout 26")
    callout.Adjustments.Item(1) = -0.5
    callout.Adjustments.Item(2) = -0.5
End Sub

すると剣先の位置とシェイプの開始座標が一致する。
f:id:t-hom:20180610013520p:plain

最初に紹介したコード中に出てくる0.5はそういうこと。

あとは狙った座標と吹き出しの座標の差分を取り、それを吹き出しの本体サイズで割ったものに補正値-0.5を追加すれば剣先の座標を狙った位置に表示できる。

以上

当ブログは、amazon.co.jpを宣伝しリンクすることによってサイトが紹介料を獲得できる手段を提供することを目的に設定されたアフィリエイト宣伝プログラムである、 Amazonアソシエイト・プログラムの参加者です。