[VBA]Excelのシートを並べ替え

[はじめに]
Excelでシートを昇順に並べ替える機会があったので、
備忘録としてサンプルソースを掲載します。
サンプルは昇順ソートですが、引数を変更すると降順にも対応できるようにしています。

[ソース]

コードのコピー

Option Explicit '''<summary> '''ソートの向き '''</summary> '''<remarks></remarks> Public Enum SortType     '昇順     Asc = 1     '降順     Desc = -1 End Enum '''<summary> '''シートをソートする。 '''</summary> '''<remarks></remarks> Public Sub SortSheet()     Dim sht As Worksheet     Dim i As Integer     Dim shtName As Variant     Dim shtNameList() As String          'シート名を配列で取得する。     For Each sht In ThisWorkbook.Worksheets         ReDim Preserve shtNameList(i)         shtNameList(i) = sht.Name         i = i + 1     Next     '配列でソートする。     SortByQuick shtNameList, SortType.Asc, 0, UBound(shtNameList)     '配列の順番でシートをソートする。     Dim strWork As String     strWork = shtNameList(UBound(shtNameList))          For i = 0 To UBound(shtNameList)         ThisWorkbook.Sheets(shtNameList(i)).Move after:=ThisWorkbook.Sheets(strWork)         strWork = shtNameList(i)     Next End Sub '''<summary> '''Stringの配列を名称の昇順にソートする。 '''</summary> '''<param name="argAry">ソート対象の配列</param> '''<param name="sort">ソートの向き　※省略時：Asc（昇順）</param> '''<param name="lngMin">対象範囲の最小インデックス ※省略時：argAryの最小インデックス</param> '''<param name="lngMax">対象範囲の最大インデックス ※省略時：argAryの最大インデックス</param> '''<remarks></remarks> Private Sub SortByQuick( _         ByRef argAry() As String, _         Optional ByVal sort As SortType = SortType.Asc, _         Optional ByVal lngMin As Long = -1, _         Optional ByVal lngMax As Long = -1)          Dim i As Long     Dim j As Long     Dim vBase As String     Dim vSwap As String          If lngMin < 0 Then         lngMin = LBound(argAry)     End If          If lngMax < 0 Then         lngMax = UBound(argAry)     End If          vBase = argAry((lngMin + lngMax) \ 2)          i = lngMin     j = lngMax          Do         Do While StrComp(argAry(i), vBase) * sort < 0             i = i + 1         Loop                  Do While StrComp(argAry(j), vBase) * sort > 0             j = j - 1         Loop                  If i >= j Then             Exit Do         End If                  vSwap = argAry(i)         argAry(i) = argAry(j)         argAry(j) = vSwap                  i = i + 1         j = j - 1     Loop          If lngMin < i - 1 Then         SortByQuick argAry, sort, lngMin, i - 1     End If          If lngMax > j + 1 Then         SortByQuick argAry, sort, j + 1, lngMax     End If End Sub

[VBA]シートの並べ替え

タグ：シートのソート シートの並べ替え VBA Excel

[VBA]複数のセルオブジェクトを１つのセルオブジェクトに統合する。

[はじめに]
・あまり知られていないかもしれませんが、
　複数のセルオブジェクトを、１つのセルオブジェクトに統合することができます。
　※Union関数を使用。

　統合後のセルに対して、
　プロパティやメソッドにアクセスすると、
　統合前のセルすべてに対して、アクセスすることと同じ意味になります。
　複数のセルオブジェクトをまとめて処理したい場合に、便利です。
　※［注意］セルの結合ではありません。

　以下は、
　「A1」、「B2:D5」、「D3,D5」の複数のセル領域を統合して、
　「Hello」の文字列を設定する例です。
　　備忘録としてサンプルソースを掲載します。

[ソース]

コードのコピー

Private Sub UnionSample()     Dim cellArray() As Variant     Dim cellUnion As Range     Dim cell As Variant          '① 統合前のセルを定義     cellArray = Array(Range("A1"), Range("B2:C5"), Range("D3:F5"))          '② ①で定義したセルを     '　 １つのセルオブジェクトに統合する。     For Each cell In cellArray         If cellUnion Is Nothing Then             '初回のみセルを設定             Set cellUnion = cell         Else             '2回目以降は、セルを統合する。             Set cellUnion = Union(cellUnion, cell)         End If          Next          '③ 統合後のセルに値を設定。     cellUnion.Value = "Hello" End Sub

[VBA]複数のセルオブジェクトを１つのセルオブジェクトに統合する。

タグ：セルを統合 VBA UNION セルをまとめる

[VBA]カラーの定数一覧

[はじめに]
・VBAで、
　色の定数を知りたいことがよくあるので、
　備忘録として掲載します。

カラーの定数一覧
ColorConstants定数

カラー	例	ColorConstants定数	R	G	B	カラー値 (R+G×256+B×2562)
黒	■	vbBlack	0	0	0	0
青	■	vbBlue	0	0	255	16711680
シアン	■	vbCyan	0	255	255	16776960
緑	■	vbGreen	0	255	0	65280
マゼンタ	■	vbMagenta	255	0	255	16711935
赤	■	vbRed	255	0	0	255
白	■	vbWhite	255	255	255	16777215
黄	■	vbYellow	255	255	0	65535

XlRgbColor定数

カラー	例	XlRgbColor定数	R	G	B	カラー値 (R+G×256+B×2562)
黒	■	rgbBlack	0	0	0	0
ディムグレー	■	rgbDimGray、rgbDimGrey	105	105	105	6908265
灰色	■	rgbGray、rgbGrey	128	128	128	8421504
濃い灰色	■	rgbDarkGray、rgbDarkGrey	169	169	169	11119017
銀色	■	rgbSilver	192	192	192	12632256
薄い灰色	■	rgbLightGray、rgbLightGrey	211	211	211	13882323
ゲーンズボロ	■	rgbGainsboro	220	220	220	14474460
ホワイトスモーク	■	rgbWhiteSmoke	245	245	245	16119285
白	■	rgbWhite	255	255	255	16777215
スノー	■	rgbSnow	255	250	250	16448255
ローズブラウン	■	rgbRosyBrown	188	143	143	9408444
薄いさんご	■	rgbLightCoral	240	128	128	8421616
インディアンレッド	■	rgbIndianRed	205	92	92	6053069
茶	■	rgbBrown	165	42	42	2763429
れんが色	■	rgbFireBrick	178	34	34	2237106
栗色	■	rgbMaroon	128	0	0	128
濃い赤	■	rgbDarkRed	139	0	0	139
赤	■	rgbRed	255	0	0	255
ミスティローズ	■	rgbMistyRose	255	228	225	14804223
サーモンピンク	■	rgbSalmon	250	128	114	7504122
トマト	■	rgbTomato	255	99	71	4678655
濃いサーモンピンク	■	rgbDarkSalmon	233	150	122	8034025
さんご	■	rgbCoral	255	127	80	5275647
オレンジレッド	■	rgbOrangeRed	255	69	0	17919
薄いサーモンピンク	■	rgbLightSalmon	255	160	122	8036607
シェンナ	■	rgbSienna	160	82	45	2970272
シーシェル	■	rgbSeashell	255	245	238	15660543
ピーチパフ	■	rgbPeachPuff	255	218	185	12180223
サンディブラウン	■	rgbSandyBrown	244	164	96	6333684
リネン	■	rgbLinen	250	240	230	15134970
ペルー	■	rgbPeru	205	133	63	4163021
ビスク	■	rgbBisque	255	228	196	12903679
濃いオレンジ	■	rgbDarkOrange	255	140	0	36095
アンティークホワイト	■	rgbAntiqueWhite	250	235	215	14150650
タン	■	rgbTan	210	180	140	9221330
バーリーウッド	■	rgbBurlyWood	222	184	135	8894686
ブランシュアーモンド	■	rgbBlanchedAlmond	255	235	205	13495295
ナバホホワイト	■	rgbNavajoWhite	255	222	173	11394815
パパイヤホイップ	■	rgbPapayaWhip	255	239	213	14020607
モカシン	■	rgbMoccasin	255	228	181	11920639
オレンジ	■	rgbOrange	255	165	0	42495
フローラルホワイト	■	rgbFloralWhite	255	250	240	15792895
オールドレース	■	rgbOldLace	253	245	230	15136253
小麦	■	rgbWheat	245	222	179	11788021
ゴールデンロッド	■	rgbGoldenrod	218	165	32	2139610
濃いゴールデンロッド	■	rgbDarkGoldenrod	184	134	11	755384
コーンシルク	■	rgbCornsilk	255	248	220	14481663
ゴールド	■	rgbGold	255	215	0	55295
レモンシフォン	■	rgbLemonChiffon	255	250	205	13499135
カーキ	■	rgbKhaki	240	230	140	9234160
濃いカーキ	■	rgbDarkKhaki	189	183	107	7059389
ペールゴールデンロッド	■	rgbPaleGoldenrod	238	232	107	7071982
アイボリー	■	rgbIvory	255	255	240	15794175
ベージュ	■	rgbBeige	245	245	220	14480885
明るい黄	■	rgbLightYellow	255	255	224	14745599
薄いゴールデンロッドイエロー	■	rgbLightGoldenrodYellow	250	250	210	13826810
オリーブ	■	rgbOlive	128	128	0	32896
黄	■	rgbYellow	255	255	0	65535
オリーブドラブ	■	rgbOliveDrab	107	142	35	2330219
イエローグリーン	■	rgbYellowGreen	154	205	50	3329434
濃いオリーブグリーン	■	rgbDarkOliveGreen	85	107	47	3107669
グリーンイエロー	■	rgbGreenYellow	173	255	47	3145645
若草色	■	rgbLawnGreen	124	252	0	64636
シャルトルーズ	■	rgbChartreuse	127	255	0	65407
ハニーデュー	■	rgbHoneydew	240	255	240	15794160
濃いシーグリーン	■	rgbDarkSeaGreen	143	188	143	9419919
明るい緑	■	rgbLightGreen	144	238	144	9498256
ペールグリーン	■	rgbPaleGreen	152	251	152	10025880
フォレストグリーン	■	rgbForestGreen	34	139	34	2263842
ライムグリーン	■	rgbLimeGreen	50	205	50	3329330
濃い緑	■	rgbDarkGreen	0	100	0	25600
緑	■	rgbGreen	0	128	0	32768
黄緑	■	rgbLime	0	255	0	65280
淡いアクアマリン	■	rgbMediumAquamarine	102	255	170	11206502
淡いシーグリーン	■	rgbMediumSeaGreen	60	179	113	7451452
シーグリーン	■	rgbSeaGreen	46	139	87	5737262
ミントクリーム	■	rgbMintCream	245	255	250	16449525
スプリンググリーン	■	rgbSpringGreen	0	255	127	8388352
淡いスプリンググリーン	■	rgbMediumSpringGreen	0	250	154	10156544
アクアマリン	■	rgbAquamarine	127	255	212	13959039
ターコイズ	■	rgbTurquoise	64	224	208	13688896
薄いシーグリーン	■	rgbLightSeaGreen	32	178	170	11186720
淡いターコイズ	■	rgbMediumTurquoise	72	209	204	13422920
空色	■	rgbAzure	240	255	255	16777200
ペールターコイズ	■	rgbPaleTurquoise	175	238	238	15658671
濃いスレートグレー	■	rgbDarkSlateGray	47	79	79	5197615
濃いスレートグレー	■	rgbDarkSlateGrey	47	79	79	5197615
青緑	■	rgbTeal	0	128	128	8421376
濃いシアン	■	rgbDarkCyan	0	139	139	9145088
明るい水色	■	rgbLightCyan	0	139	139	9145088
濃いターコイズ	■	rgbDarkTurquoise	0	206	209	13749760
水色	■	rgbAqua	0	255	255	16776960
カデットブルー	■	rgbCadetBlue	95	158	160	10526303
パウダーブルー	■	rgbPowderBlue	176	224	230	15130800
明るい青	■	rgbLightBlue	173	216	230	15128749
深いスカイブルー	■	rgbDeepSkyBlue	0	191	255	16760576
スカイブルー	■	rgbSkyBlue	135	206	235	15453831
薄いスカイブルー	■	rgbLightSkyBlue	135	206	250	16436871
アリスブルー	■	rgbAliceBlue	240	248	255	16775408
スチールブルー	■	rgbSteelBlue	70	130	180	11829830
スレートグレー	■	rgbSlateGray	112	128	144	9470064
薄いスレートグレー	■	rgbLightSlateGray	119	136	153	10061943
ドジャーブルー	■	rgbDodgerBlue	30	144	255	16748574
薄いスチールブルー	■	rgbLightSteelBlue	176	196	222	14599344
コーンフラワーブルー	■	rgbCornflowerBlue	100	149	237	15570276
ロイヤルブルー	■	rgbRoyalBlue	65	105	225	14772545
ゴーストホワイト	■	rgbGhostWhite	248	248	255	16775416
ラベンダー	■	rgbLavender	230	230	250	16443110
ミッドナイトブルー	■	rgbMidnightBlue	25	25	112	7346457
ネイビー	■	rgbNavy、rgbNavyBlue	0	0	128	8388608
濃い青	■	rgbDarkBlue	0	0	139	9109504
淡い青	■	rgbMediumBlue	0	0	205	13434880
青	■	rgbBlue	0	0	255	16711680
濃いスレートブルー	■	rgbDarkSlateBlue	72	61	139	9125192
スレートブルー	■	rgbSlateBlue	106	90	205	13458026
淡いスレートブルー	■	rgbMediumSlateBlue	123	104	238	15624315
淡い紫	■	rgbMediumPurple	147	112	219	14381203
青紫	■	rgbBlueViolet	138	43	226	14822282
インディゴ	■	rgbIndigo	75	0	130	8519755
濃いオーキッド	■	rgbDarkOrchid	153	50	204	13382297
濃い紫	■	rgbDarkViolet	148	0	211	13828244
淡いオーキッド	■	rgbMediumOrchid	186	85	211	13850042
あざみ色	■	rgbThistle	216	191	216	14204888
プラム	■	rgbPlum	221	160	221	14524637
紫色	■	rgbViolet	238	130	238	15631086
紫	■	rgbPurple	128	0	128	8388736
濃いマゼンタ	■	rgbDarkMagenta	139	0	139	9109643
明るい紫	■	rgbFuchsia	255	0	255	16711935
オーキッド	■	rgbOrchid	218	112	214	14053594
淡いバイオレットレッド	■	rgbMediumVioletRed	199	21	133	8721863
深いピンク	■	rgbDeepPink	255	20	147	9639167
ホットピンク	■	rgbHotPink	255	105	180	11823615
ラベンダーブラッシュ	■	rgbLavenderBlush	255	240	245	16118015
ペールバイオレットレッド	■	rgbPaleVioletRed	219	112	147	9662683
深紅	■	rgbCrimson	220	20	60	3937500
ピンク	■	rgbPink	255	192	203	13353215
薄いピンク	■	rgbLightPink	255	182	193	12695295

タグ：XlRgbColor定数 ColorConstants定数 色の定数 VBA

[VBA]RGBカラー値からRGBの各々の値を取得

[はじめに]
・RGBの各要素からRGBカラー値を取得する為に、
　VBAではRGB関数が用意されていますが、
　その逆（RGBカラー値から元のRGB各要素を取得）の関数は
　用意されていません。

　たまに必要になることがあるので、
　ユーザ定義関数を作成しましたので、備忘録として掲載します。

[ソース]

コードのコピー

'[機能] '　RGB カラー値から、 '　赤(R)、緑(G)、青(B)の各々の値を取得する。 '[引数] '　rgbColor：RGB カラー値 '[戻り値] '　RGBの各値（配列） '　　０番目：赤(R) '　　１番目：緑(G) '　　２番目：青(B) Public Function GetRgbValues(ByVal rgbColor As Long) As Integer()     Dim rtnColors(2) As Integer     '赤(R)     rtnColors(0) = rgbColor Mod 256     '緑(G)     rtnColors(1) = rgbColor \ 256 Mod 256     '青(B)     rtnColors(2) = rgbColor \ 65536     GetRgbValues = rtnColors End Function

[VBA]RGBカラー値から赤(R)、緑(G)、青(B)の各々の値を取得

タグ：VBA 各々の値を取得 RGB

[VBA]セルの取得、値の書き込み

[はじめに]
・Excel VBAでよくセルの情報を取得することがありますが、
　様々な書き方があるので、備忘録に記載します。

　セル座標をA1形式や行列番号で指定したり、
　複数セルの範囲指定、その他のブックやシート上のセルの取得　など
　用途に応じたパターンを適用頂ければと思います。

[ソース]

コードのコピー

Private Sub WriteToCellValue()     '■■■１．「Ａ１形式」でセルを指定する。     '　①単一セルを扱う。     '　※例：セルA1に値を出力     Range("A1").Value = "あ"          '　②複数セルを扱う（その１）     '　※例：セルA3～A5に値を出力     Range("A3:A5").Value = "い"     '　③複数セルを扱う（その２）     '　※例：セルC1～D10に値を出力     Range(Range("C1"), Range("D10")).Value = "う"     '■■■２．行番号、列番号でセルを指定する。     '　行番号、列番号をカウントアップ等をさせたい場合、有効。     '　※例：セル（1行目、6列目）に値を出力     Cells(1, 6).Value = "え"     '■■■３．特定のセル範囲内から、相対的にセルを取得     '　※例：セルD4（B3～E5内で2行目、3列目）に値を出力     Range("B3:E5").Cells(2, 3).Value = "お"     '■■■４．特定のセル範囲内から、相対的な行を取得     '　※例：B3～E5内の1行目に値を出力     Range("B3:E5").Rows(1).Value = "か"     '■■■５．特定のセル範囲内から、相対的な列を取得     '　※B3～E5内の3列目に値を出力     Range("B3:E5").Columns(3).Value = "き"     '■■■６．他のシートのセルを扱う。     '　指定セルが、他のシートにある場合は、     '　以下のように記載します。     '　シート省略時は、アクティブシートが対象になります。     '　※例：シートSheet1のセルA2に値を出力     '　　　以下例のRangeは上記の１～５の表記でも可能。     Sheets("Sheet1").Range("A2").Value = "く"     '■■■７．他のブックのセルを扱う。     '　指定セルが、他のブック、シートにある場合は、     '　以下のように記載します。     '　ブック省略時は、アクティブブックが対象になります。     '　※例：当ブックのシートSheet1のセルA3に値を出力     '　　　以下例のRangeは上記の１～５の表記でも可能。     ThisWorkbook.Sheets("Sheet1").Range("A3").Value = "け" End Sub

[VBA]セルの選択

タグ：range cells セルの値の書き込み セルの取得 VBA

[VBA]クラスモジュールのインスタンス生成タイミングについて

[はじめに]
VBAは、Javaや.NET系言語程ではありませんが、
オブジェクト指向をサポートしています。

Javaや.NETとの違いの１つとして、
インスタンスの生成タイミングがあります。
Javaや.NETの感覚でコーディングすると間違いに陥りやすいので、
備忘録として記載します。

[インスタンスの生成タイミング]
インスタンスの生成はJavaなどでは、
『New』を指定するとインスタンスが生成されますが、
VBAでは記載の仕方によって、
必ずしも生成されるとは限りません。

例えば、Javaの場合、
newを指定するタイミングでインスタンスが生成され、
その参照が変数に格納されます。

それに対して、VBAの場合は、
Newを指定したタイミングではインスタンスは生成されず、
その変数に初めてアクセス（メソッド呼出しなど）するタイミングで、
インスタンスが生成されます。

インスタンス生成タイミングの検証として、
下記のコードを実行してみると以下のようになります。
もし、Javaや.NETと同じように
宣言時にインスタンス生成がされるのであれば、
出力結果は、
　(1)インスタンスをNew付で宣言します。
　(a)インスタンスが生成されました。　★JavaやC#ならこのタイミング
　(2)これからインスタンスにアクセスします。
　(b)MethodA実行中
となるはずですが、
実際は次のようになります。
　(1)インスタンスをNew付で宣言します。
　(2)これからインスタンスにアクセスします。
　(a)インスタンスが生成されました。　★VBAの場合、初回メソッド実行時
　(b)MethodA実行中
これは、宣言時にインスタンスは作成しておらず、
MethodAを実行する際に、インスタンスが生成していることを示します。

[VBAのコード]

コードのコピー

Option Explicit Private Sub TestA()     Dim a As New Hoge     Debug.Print "(1)インスタンスをNew付で宣言します。"     Debug.Print "(2)これからインスタンスにアクセスします。"     a.MethodA     '実行結果     '(1)インスタンスをNew付で宣言します。     '(2)これからインスタンスにアクセスします。     '(a)インスタンスが生成されました。     '(b)MethodA実行中 End Sub

[VBA]インスタンスの生成タイミングの検証（Hogeクラスの呼出し側）

コードのコピー

Option Explicit Private Sub Class_Initialize()     Debug.Print "(a)インスタンスが生成されました。" End Sub Public Sub MethodA()     Debug.Print "(b)MethodA実行中" End Sub

[VBA]インスタンスの生成タイミングの検証（Hogeクラス）

[その他]
　VBAを例に説明していますが、
　VisualBasic6（VB6）系の言語にも同様なことが言えます。

タグ：クラスモジュール インスタンスの生成 VBA Initializeイベント

[VBA]文字コードを指定してファイルにテキストを出力するクラスモジュール

[はじめに]
・最近、JSONファイルを扱うことがあり、
　UTF-8でテキストファイルを作成する機会があったので、
　作ってみました。
　備忘録としてサンプルを掲載します。
　クラスモジュールで定義することを前提としています。

[ソース]

コードのコピー

''' <summary> ''' クラスモジュール名：TextWriterWithCharaSet ''' 文字コードを指定してファイルにテキストを出力するクラス ''' </summary> ''' <remarks></remarks> Option Explicit 'ファイルのバッファサイズ Private Const BUF_SIZE As Integer = 1024 '文字コード（デフォルト：UTF-8） Public CharCode As String '出力ディレクトリ Public TargetDirectory As String '出力ファイル名 Public TargetFileName As String 'FileSystemObject Private objFs As Object 'ADODB.Stream Private objStream As Object 'ADODB.StreamのSaveOptionsEnum Private Enum SaveOptionsEnum     'ファイルが存在しない場合にのみ作成します。     '存在する場合はエラー。（既定値）     adSaveCreateNotExist = 1     'ファイルが存在する場合は、     'ファイルを上書きします。     adSaveCreateOverWrite = 2 End Enum '出力テキストのコレクション Private colTraget As New Collection ''' <summary> ''' Initializeイベント（コンストラクタ） ''' </summary> ''' <remarks></remarks> Private Sub Class_Initialize()     Set objStream = CreateObject("ADODB.Stream")     Set objFs = CreateObject("Scripting.FileSystemObject")          Me.CharCode = "UTF-8"          Call ClearBuffer End Sub ''' <summary> ''' Terminateイベント（デストラクタ） ''' </summary> ''' <remarks></remarks> Private Sub Class_Terminate()           Call Flush          Set objStream = Nothing     Set objFs = Nothing End Sub ''' <summary> ''' テキストを出力する。 ''' </summary> ''' <param name="strText">出力テキスト</param> ''' <param name="useBuffer">バッファの利用有無（※省略時はTrue）</param> ''' <remarks></remarks> Public Sub WriteText( _     ByVal strText As String, _     Optional ByVal useBuffer As Boolean = True)          colTraget.Add strText          If useBuffer = True Then         'バッファ有効の場合は、         '一旦、バッファに溜めておき、         '特定サイズを越えてからファイル出力する。         If colTraget.Count > BUF_SIZE Then             Me.Flush         End If     Else         'バッファ無効の場合は、ファイルに出力         Me.Flush     End If End Sub ''' <summary> ''' バッファーの内容をテキストに出力する。 ''' </summary> ''' <remarks></remarks> Public Sub Flush()           Dim i As Long     Dim targetFilePath As String          On Error GoTo LBL_ERR:           'ファイルパスを生成     targetFilePath = objFs.BuildPath( _         GetTargetDirectory(), TargetFileName)          With objStream         .Charset = Me.CharCode         .Open                  'ファイルが既に存在する場合は、全テキストを読込む。         '※追記書込みができないので、         '  既存テキストをメモリ上に取込んでから上書きする。         If objFs.FileExists(targetFilePath) Then             .LoadFromFile targetFilePath             .Position = .Size         End If         For i = 1 To colTraget.Count             .WriteText colTraget(i)         Next                  .SaveToFile targetFilePath, _             SaveOptionsEnum.adSaveCreateOverWrite                  .Close          End With           Call ClearBuffer          Exit Sub LBL_ERR:           Call ClearBuffer            Err.Raise _          Number:=Err.Number, _          Description:="テキストの出力に失敗しました。" & _          Err.Description End Sub ''' <summary> ''' 出力ディレクトリを取得する。 ''' </summary> ''' <returns>出力ディレクトリ（デフォルト：ThisWorkbook.path）</returns> ''' <remarks></remarks> Private Function GetTargetDirectory() As String      If Me.TargetDirectory = "" Then          GetTargetDirectory = ThisWorkbook.path          Exit Function      End If      GetTargetDirectory = Me.TargetDirectory End Function ''' <summary> ''' 出力ファイルパスを設定する。 ''' </summary> ''' <param name="targetFilePath">出力ファイルパス</param> ''' <remarks></remarks> Public Sub SetFilePath(ByVal targetFilePath As String)           With objFs         Me.TargetDirectory = _             .GetParentFolderName(targetFilePath)         Me.TargetFileName = _             objFs.GetFileName(targetFilePath)     End With End Sub ''' <summary> ''' バッファーをクリアする。 ''' </summary> ''' <remarks></remarks> Public Sub ClearBuffer()      Dim i As Long            For i = colTraget.Count To 1 Step -1          colTraget.Remove i      Next End Sub

[VBA]文字コードを指定してファイルにテキストを出力するクラスモジュール

[ソース]

コードのコピー

Private Sub CommandButton1_Click()     Dim rw As New TextWriterWithCharaSet          rw.CharCode = "UTF-8"     rw.SetFilePath "C:\aaa\hogehoge.txt"     rw.WriteText "ABCDE", True          Set rw = Nothing      End Sub

[VBA]使用例

タグ：ファイル出力 UTF-8 VBA

[VBA]ログを出力するクラスモジュール

[はじめに]
・最近、Excelマクロを使う機会が増えたので、
　備忘録としてサンプルを掲載します。
　クラスモジュールで定義することを前提としています。

[ソース]

コードのコピー

''' <summary> ''' クラスモジュール名：LogForExcel ''' ログ出力を制御するクラス ''' </summary> ''' <remarks></remarks> Option Explicit 'ログファイルのプレフィックス Private Const LOG_FILE_PREFIX As String = "LOG_" 'ログファイルの拡張子 Private Const LOG_FILE_EXTENSION As String = ".log" 'ログファイルのバッファサイズ Private Const LOG_BUF_SIZE As Integer = 1024 'ログ出力ディレクトリ Public LogDirectory As String 'FileSystemObject Private objFs As Object 'TextStreamObjectのIOモード Private Enum IOMode     ForReading = 0  '読み取り専用モード（既定値）     ForWriting = 1  '上書きモード     ForAppending = 8    '追記モード End Enum 'ログ出力対象 Private colTraget As New Collection ''' <summary> ''' Initializeイベント（コンストラクタ） ''' </summary> ''' <remarks></remarks> Private Sub Class_Initialize()     Set objFs = CreateObject("Scripting.FileSystemObject")          Call ClearLog End Sub ''' <summary> ''' Terminateイベント（デストラクタ） ''' </summary> ''' <remarks></remarks> Private Sub Class_Terminate()          Call Flush          Set objFs = Nothing End Sub ''' <summary> ''' ログを出力する。[Information] ''' </summary> ''' <param name="msg">出力メッセージ</param> ''' <param name="useBuffer">バッファの利用有無</param> ''' <remarks></remarks> Public Sub OutputInfo( _     ByVal msg As String, _     Optional ByVal useBuffer As Boolean = False)          Call OutputLog("Informaton", msg, useBuffer)      End Sub ''' <summary> ''' ログを出力する。[Warning] ''' </summary> ''' <param name="msg">出力メッセージ</param> ''' <param name="useBuffer">バッファの利用有無</param> ''' <remarks></remarks> Public Sub OutputWarn( _     ByVal msg As String, _     Optional ByVal useBuffer As Boolean = False)          Call OutputLog("Warning", msg, useBuffer)      End Sub ''' <summary> ''' ログを出力する。[Error] ''' </summary> ''' <param name="msg">出力メッセージ</param> ''' <param name="objErr">エラーオブジェクト</param> ''' <param name="useBuffer">バッファの利用有無</param> ''' <remarks></remarks> Public Sub OutputError( _     ByVal msg As String, _     Optional ByVal objErr As ErrObject = Nothing, _     Optional ByVal useBuffer As Boolean = False)          Dim strMsg As String          strMsg = msg          If Not (objErr Is Nothing) Then         strMsg = strMsg & ":" & _             "Err.Number:[" & objErr.Number & "]," & _             "Err.Description:[" & objErr.Description & "]:"     End If          Call OutputLog("Error", strMsg, useBuffer) End Sub ''' <summary> ''' ログを出力する。 ''' </summary> ''' <param name="logType">ログ種別</param> ''' <param name="msg">出力メッセージ</param> ''' <param name="useBuffer">バッファの利用有無</param> ''' <remarks></remarks> Private Sub OutputLog( _     ByVal logType As String, _     ByVal msg As String, _     ByVal useBuffer As Boolean)     colTraget.Add _         Format(Now, "yyyy/mm/dd hh:mm:ss") & ":" & _         logType & ":" & msg     If useBuffer = True Then         If colTraget.Count > LOG_BUF_SIZE Then             'バッファがサイズを超えた場合は、ファイルに出力             Me.Flush         End If     Else         'バッファ無効の場合は、ファイルに出力         Me.Flush     End If End Sub ''' <summary> ''' バッファーのデータをログに出力する。 ''' </summary> ''' <remarks></remarks> Public Sub Flush()          Dim objTs As Object 'TextStreamObject     Dim i As Long          On Error GoTo LBL_ERR:          Set objTs = objFs.OpenTextFile( _         fileName:=objFs.BuildPath( _             GetLogDirectory(), _             LOG_FILE_PREFIX & _             Format(Now, "yyyymmdd") & _             LOG_FILE_EXTENSION), _         IOMode:=IOMode.ForAppending, _         Create:=True)     For i = 1 To colTraget.Count         objTs.WriteLine colTraget(i)     Next          objTs.Close     Set objTs = Nothing     Call ClearLog    Exit Sub LBL_ERR:         If Not (objTs Is Nothing) Then         objTs.Close         Set objTs = Nothing     End If          Call ClearLog          Err.Raise _         Number:=Err.Number, _         Description:="ログの出力に失敗しました。" & _         Err.Description End Sub ''' <summary> ''' ログ出力ディレクトリを取得する。 ''' </summary> ''' <returns>ログ出力ディレクトリ（デフォルト：ThisWorkbook.path）</returns> ''' <remarks></remarks> Private Function GetLogDirectory() As String     If Me.LogDirectory = "" Then         GetLogDirectory = ThisWorkbook.Path         Exit Function     End If          GetLogDirectory = Me.LogDirectory End Function ''' <summary> ''' バッファーをクリアする。 ''' </summary> ''' <remarks></remarks> Public Sub ClearLog()     Dim i As Long          For i = colTraget.Count To 1 Step -1         colTraget.Remove i     Next End Sub

[VBA]ログを出力するクラスモジュール

[ソース]

コードのコピー

Private Sub CommandButton1_Click()     Dim logger As New LogForExcel          On Error GoTo LBL_ERR          'ログ出力[Info]     Call logger.OutputInfo("出力テスト（Info）", True)     'ログ出力[Warn]     Call logger.OutputWarn("出力テスト（Warn）", True)          'ゼロ除算で意図的に例外を発生させる。     Debug.Print 1 / 0          Set logger = Nothing          Exit Sub LBL_ERR:          'ログ出力[Error]     Call logger.OutputError("出力テスト（Error）", Err, True)          Set logger = Nothing End Sub

[VBA]使用例

タグ：ログ VBA ログ出力

[VBA]ファイル保存ダイアログの表示

[はじめに]
・最近、Excelマクロを使う機会が増えたので、
　備忘録としてサンプルを掲載します。
　VBAの関数が使いにくいので、クラスモジュールにまとめてみました。
　.NETのSaveFileDialogクラスを真似して実装しているので、
　.NET開発者にとっては、お馴染みのインタフェースで使いやすいかと思います。

[ソース]

コードのコピー

''' <summary> ''' クラスモジュール名：SaveFileDialog ''' ファイル保存ダイアログを制御するクラス ''' </summary> ''' <remarks></remarks> Option Explicit 'FileSystemPbject Private objFs As Object 'タイトル Public Title As String '初期ディレクトリ Public InitialDirectory As String '初期ファイル名 Public InitialFileName As String '[ファイルの種類]の選択肢 Public Filter As String '[ファイルの種類]の選択値 Public FilterIndex As Integer '選択したファイル名 Private m_FileName As String ''' <summary> ''' Initializeイベント（コンストラクタ） ''' </summary> ''' <remarks></remarks> Private Sub Class_Initialize()     Set objFs = CreateObject("Scripting.FileSystemObject")          Call Clear End Sub ''' <summary> ''' Terminateイベント（デストラクタ） ''' </summary> ''' <remarks></remarks> Private Sub Class_Terminate()     Set objFs = Nothing End Sub ''' <summary> ''' 初期化 ''' </summary> ''' <remarks></remarks> Public Sub Clear()          Me.InitialDirectory = Application.ThisWorkbook.path     Me.InitialFileName = ""     Me.Filter = "すべてのファイル(*.*),*.*"     Me.FilterIndex = 1     Me.Title = ""     m_FileName = "ファイル名を指定してください" End Sub ''' <summary> ''' フィルターを設定 ''' </summary> ''' <param name="filterArray">フィルター文字列</param> ''' <remarks></remarks> Public Sub SetFilterList(ParamArray filterArray() As Variant)     Filter = Join(filterArray, ",") End Sub ''' <summary> ''' 選択したファイル名を取得する。 ''' </summary> ''' <remarks></remarks> Public Function GetSelectedFileName() As String     GetSelectedFileName = m_FileName End Function ''' <summary> ''' パスとファイル名を結合する。 ''' </summary> ''' <param name="path">パス</param> ''' <param name="fileName">ファイル名</param> ''' <returns>結合後のフルパス</returns> ''' <remarks></remarks> Private Function BuildPath( _     ByVal path As String, _     ByVal fileName As String) As String          BuildPath = objFs.BuildPath(path, fileName) End Function ''' <summary> ''' ファイル保存ダイアログを開く ''' </summary> ''' <returns>vbOK：ファイル選択、vbCancel：キャンセル</returns> ''' <remarks></remarks> Public Function ShowDialog() As VbMsgBoxResult     Dim resDlg As Variant     Dim initDir As String          '初期ディレクトリの存在チェック     ' 存在しない場合は、Excelブックの配置ディレクトリに置き換える。     If objFs.FolderExists(Me.InitialDirectory) = False Then         Me.InitialDirectory = ThisWorkbook.path     End If          'ファイル選択ダイアログを開く     resDlg = _          Application.GetSaveAsFilename( _               InitialFileName:= _                 BuildPath( _                     Me.InitialDirectory, _                     Me.InitialFileName), _               FileFilter:=Me.Filter, _               FilterIndex:=Me.FilterIndex, _               Title:=Me.Title _              )     If resDlg = False Then         'キャンセルした場合         m_FileName = ""                  ShowDialog = vbCancel         Exit Function     End If          'ファイル選択した場合     m_FileName = resDlg          ShowDialog = vbOK     Exit Function      End Function

VBA]ファイル保存ダイアログ

[ソース]

コードのコピー

Private Sub CommandButton1_Click()     Dim sfd As New SaveFileDialog          With sfd         .InitialDirectory = "C:\Hoge"         .InitialFileName = "abc.csv"         .Title = "タイトル"         .FilterIndex = 1         .SetFilterList "CSV(*.csv),*.csv", "すべてのファイル(*.*),*.*"              End With          'ファイル保存ダイアログを開く。     If sfd.ShowDialog() = vbOK Then         MsgBox sfd.GetSelectedFileName()     Else         MsgBox "キャンセルしました"     End If          '終了処理     Set sfd = Nothing End Sub

VBA]使用例

タグ：ファイル保存ダイアログ VBA

[VBA]ファイル選択ダイアログの表示

[はじめに]
・最近、Excelマクロを使う機会が増えたので、
　備忘録としてサンプルを掲載します。
　VBAの関数が使いにくいので、クラスモジュールにまとめてみました。
　.NETのOpenFileDialogクラスを真似して実装しているので、
　.NET開発者にとっては、お馴染みのインタフェースで使いやすいかと思います。

[ソース]

コードのコピー

''' <summary> ''' クラスモジュール名：OpenFileDialog ''' ファイル選択ダイアログを制御するクラス ''' </summary> ''' <remarks></remarks> Option Explicit 'FileSystemPbject Private objFs As Object 'WScript.Shell Private objWs As Object 'タイトル Public Title As String '初期ディレクトリ Public InitialDirectory As String '[ファイルの種類]の選択肢 Public Filter As String '[ファイルの種類]の選択値 Public FilterIndex As Integer '複数選択の可否 Public MultiSelect As Boolean '選択したファイル名 Private m_FileNames() As String ''' <summary> ''' Initializeイベント（コンストラクタ） ''' </summary> ''' <remarks></remarks> Private Sub Class_Initialize()     Set objFs = CreateObject("Scripting.FileSystemObject")     Set objWs = CreateObject("WScript.Shell")          Call Clear End Sub ''' <summary> ''' Terminateイベント（デストラクタ） ''' </summary> ''' <remarks></remarks> Private Sub Class_Terminate()     Set objFs = Nothing     Set objWs = Nothing End Sub ''' <summary> ''' 初期化 ''' </summary> ''' <remarks></remarks> Public Sub Clear()          Me.InitialDirectory = Application.ThisWorkbook.path     Me.Filter = "すべてのファイル(*.*),*.*"     Me.FilterIndex = 1     Me.Title = "ファイルを選択してください"     Me.MultiSelect = True     ReDim m_FileNames(0) End Sub ''' <summary> ''' フィルターを設定 ''' </summary> ''' <param name="filterArray">フィルター文字列</param> ''' <remarks></remarks> Public Sub SetFilterList(ParamArray filterArray() As Variant)     Filter = Join(filterArray, ",") End Sub ''' <summary> ''' 選択したファイル名を取得する。 ''' </summary> ''' <remarks></remarks> Public Function GetSelectedFileNames() As String()     GetSelectedFileNames = m_FileNames End Function ''' <summary> ''' ファイル選択ダイアログを開く ''' </summary> ''' <returns>vbOK：ファイル選択、vbCancel：キャンセル</returns> ''' <remarks></remarks> Public Function ShowDialog() As VbMsgBoxResult     Dim resDlg As Variant     'カレントディレクトリを設定     objWs.CurrentDirectory = Me.InitialDirectory           'ファイル選択ダイアログを開く     resDlg = _          Application.GetOpenFilename( _               FileFilter:=Me.Filter, _               FilterIndex:=Me.FilterIndex, _               Title:=Me.Title, _               MultiSelect:=Me.MultiSelect _              )     If IsArray(resDlg) = False Then         If resDlg = False Then             'キャンセルした場合             ReDim m_FileNames(0)                          ShowDialog = vbCancel             Exit Function         End If     End If          ReDim m_FileNames(0)          'ファイル選択した場合     If IsArray(resDlg) = True Then         '複数選択の場合         Dim cnt_i As Integer                  For cnt_i = 1 To UBound(resDlg)             ReDim Preserve m_FileNames(cnt_i - 1)             m_FileNames(cnt_i - 1) = resDlg(cnt_i)         Next                  ShowDialog = vbOK         Exit Function     Else         '単一選択の場合         ReDim m_FileNames(0)         m_FileNames(0) = resDlg              ShowDialog = vbOK         Exit Function     End If      End Function

[VBA]ファイル選択ダイアログ

[ソース]

コードのコピー

Private Sub CommandButton1_Click()          Dim ofd As New OpenFileDialog          With ofd         .Title = "ファイル選択ダイアログ（単一選択）"         .FilterIndex = 1         .MultiSelect = False         .SetFilterList "CSV(*.csv),*.csv", "すべてのファイル(*.*),*.*"              End With          'ファイル選択ダイアログを開く。     If ofd.ShowDialog() = vbOK Then                  Dim cntI As Integer         Dim fList() As String                  fList = ofd.GetSelectedFileNames()                  For cntI = 0 To UBound(fList)             MsgBox fList(cntI)         Next     Else         MsgBox "キャンセルしました"     End If     '終了処理     Set ofd = Nothing End Sub

[VBA]使用例

タグ：VBA ファイル選択ダイアログ

[VBA]指定したブック内のシート検索

[はじめに]
・最近、Excelマクロを使う機会が増えたので、備忘録としてサンプルを掲載します。
　指定したブック内のシートを検索する処理です。

[ソース]

コードのコピー

Option Explicit ''' <summary> ''' 指定したブック検索する。 ''' </summary> ''' <param name="bookName">ブック名</param> ''' <returns>対象のWorkBook。（存在しない場合はNothing）</returns> ''' <remarks></remarks> Public Function FindBook( _     ByVal bookName As String) As Workbook     Dim bk As Workbook          For Each bk In Workbooks         If bk.name = bookName Then             Set FindBook = Workbooks(bk.name)             Exit Function         End If     Next End Function ''' <summary> ''' 指定したブック内のシートを検索する。 ''' </summary> ''' <param name="sheetName">シート名</param> ''' <param name="bookName">ブック名（※省略時はThisWorkbook.Name）</param> ''' <returns>対象のWorkSheet。（存在しない場合はNothing）</returns> ''' <remarks></remarks> Public Function FindSheet( _     ByVal sheetName As String, _     Optional ByVal bookName As String = "") As Worksheet     Dim bk As Workbook     Dim sht As Worksheet     If bookName = "" Then         'ブック名を省略した場合は、         '自分自身のブックを対象とする。         Set bk = ThisWorkbook     Else         Set bk = FindBook(bookName)                  If bk Is Nothing Then             '指定したブック名が存在しない場合は、Nothingを返す。             Set FindSheet = Nothing             Exit Function         End If              End If          For Each sht In bk.Sheets         If sht.name = sheetName Then             Set FindSheet = bk.Worksheets(sht.name)             Exit Function         End If     Next     'シートが存在しない場合、Nothingを返す。     Set FindSheet = Nothing End Function

[VBA]指定したブック内のシートを検索

タグ：シートの存在チェック シートの検索 VBA

[VBA]罫線描画＆罫線消去

[はじめに]
・Excelマクロで罫線描画、罫線消去を実装することがよくあります。
　『マクロの記録』で簡単に作れますが、汎用性がないので関数化しました。
　機能は単純に、セル範囲に罫線（外枠、内側の境界線）を描画するだけです。
　とりあえず、備忘録として載せておきます。

[ソース]

コードのコピー

Option Explicit ''' <summary> ''' 指定したセル範囲に罫線を描画する。（外枠、内側の境界線） ''' </summary> ''' <param name="targetRange">対象セル範囲</param> ''' <remarks></remarks> Public Sub DrawLine(ByVal targetRange As Range)     With targetRange              '個々のセルの右上がり斜線         .Borders(xlDiagonalUp).LineStyle = xlNone                  '個々のセルの右下がり斜線         .Borders(xlDiagonalDown).LineStyle = xlNone                  'セル範囲の最上端         With .Borders(xlEdgeTop)             .LineStyle = xlContinuous             .ColorIndex = xlAutomatic             .TintAndShade = 0             .Weight = xlThin         End With                  'セル範囲の最下端         With .Borders(xlEdgeBottom)             .LineStyle = xlContinuous             .ColorIndex = xlAutomatic             .TintAndShade = 0             .Weight = xlThin         End With                  'セル範囲の最左端         With .Borders(xlEdgeLeft)             .LineStyle = xlContinuous             .ColorIndex = xlAutomatic             .TintAndShade = 0             .Weight = xlThin         End With                  'セル範囲の最右端         With .Borders(xlEdgeRight)             .LineStyle = xlContinuous             .ColorIndex = xlAutomatic             .TintAndShade = 0             .Weight = xlThin         End With                  If .Cells(1).Row < .Cells(.Count).Row Then             'セル範囲の上下端以外の境界線             '【注意（Excel2003以前のみ】             ' セル範囲が複数行にわたる場合のみ処理します。             ' 単数行の場合に処理するとエラーになることがあります。             With .Borders(xlInsideHorizontal)                 .LineStyle = xlContinuous                 .ColorIndex = xlAutomatic                 .TintAndShade = 0                 .Weight = xlThin             End With         End If         If .Cells(1).Column < .Cells(.Count).Column Then             'セル範囲の左右端以外の境界線             '【注意（Excel2003以前のみ】             ' セル範囲が複数列にわたる場合のみ処理します。             ' 単数列の場合に処理するとエラーになることがあります。             With .Borders(xlInsideVertical)                 .LineStyle = xlContinuous                 .ColorIndex = xlAutomatic                 .TintAndShade = 0                 .Weight = xlThin             End With         End If     End With End Sub ''' <summary> ''' 指定したセル範囲の罫線を消去する。（外枠、内側の境界線） ''' </summary> ''' <param name="targetRange">対象セル範囲</param> ''' <remarks></remarks> Public Sub EraseLine(ByVal targetRange As Range)          With targetRange                  '個々のセルの右上がり斜線         .Borders(xlDiagonalUp).LineStyle = xlNone                  '個々のセルの右下がり斜線         .Borders(xlDiagonalDown).LineStyle = xlNone                  'セル範囲の最上端         .Borders(xlEdgeTop).LineStyle = xlNone                  'セル範囲の最下端         .Borders(xlEdgeBottom).LineStyle = xlNone                  'セル範囲の最左端         .Borders(xlEdgeLeft).LineStyle = xlNone                  'セル範囲の最右端         .Borders(xlEdgeRight).LineStyle = xlNone                  If .Cells(1).Row < .Cells(.Count).Row Then             'セル範囲の上下端以外の境界線             '【注意（Excel2003以前のみ）】             ' セル範囲が複数行にわたる場合のみ処理します。             ' 単数行の場合に処理するとエラーになります。             .Borders(xlInsideHorizontal).LineStyle = xlNone         End If                  If .Cells(1).Column < .Cells(.Count).Column Then             'セル範囲の左右端以外の境界線             '【注意（Excel2003以前のみ）】             ' セル範囲が複数列にわたる場合のみ処理します。             ' 単数列の場合に処理するとエラーになることがあります。             .Borders(xlInsideVertical).LineStyle = xlNone         End If              End With End Sub

[ExcelVBA]罫線の描画＆消去

コードのコピー

Private Sub CommandButton1_Click()     '罫線描画     Call DrawLine(Selection) End Sub Private Sub CommandButton2_Click()     '罫線消去     Call EraseLine(Selection) End Sub

[ExcelVBA]呼び出し例

タグ：罫線クリア 罫線のクリア 罫線の消去 罫線描画 罫線 罫線の描画 VBA 罫線消去

[VBA]ExcelVBAでオブジェクト指向の継承

[ポイント]
・ExcelのVBA（Visual Basic for Application）は、
　完全オブジェクト指向言語（JavaやC#等）ほどではないですが、
　オブジェクト指向によるプログラミングをサポートしています。
　『オブジェクト指向』と言えば、
　代表的な性質として以下の３つのキーワードがあります。
代表的な性質

継承

２つのクラス間で親子関係を持ち、子クラスが親クラスの性質を受け継ぐこと。

カプセル化

オブジェクト内部のデータを隠蔽したり(データ隠蔽)、オブジェクトの振る舞いを隠蔽したり、 オブジェクトの実際の型を隠蔽したりすることをいう。

多態性（ポリモフィズム）

実行される処理の実体が、コールされたメッセージではなく、メッセージを受けたオブジェクトに よって決定される性質。 また、この性質を使って、 「同一のメッセージを使って、オブジェクトごとに異なった処理を行わせること」

[VBAのオブジェクト指向]
　VBAのオブジェクト指向は、完全オブジェクト指向言語（JavaやC#等）のそれと比べると、
　『子クラスのメソッドを経由して親クラスの変数やメソッドにアクセスできない』、
　『子クラス内から親クラスの変数やメソッドにアクセスできない』等の制限事項がある。
[多態性（ポリモフィズム）]
　『多態性（ポリモフィズム）』の説明で、
　『動物』に『鳴く』メッセージを通知する例がよく挙げられる。
　以下に、『多態性（ポリモフィズム）』を利用したサンプルコードを示す。
[クラス図]

[クラスの説明]
・Mammalクラス
　哺乳類を表すクラス。
　メソッドとして、Cry（）を実装。
・Dogクラス、Catクラス、Crowクラス
　イヌ、ネコ、カラスを表すクラス。各々のクラスはMammal（哺乳類）クラスを継承。
　メソッドとして、Mammal_Cry（）を実装。
　（[親クラス名]_[親クラスのメソッド名]で、親クラスのメソッドをオーバーライドできます。）
[多態性（ポリモフィズム）]
・Dogオブジェクト、Catオブジェクト、Crowオブジェクトを
　Mammalオブジェクトの配列に格納する。
　MammalオブジェクトのCrowメソッドを経由して、
　Dogオブジェクト、Catオブジェクト、CrowオブジェクトのCrowメソッドを呼ぶ。
　以下のサンプルでは、３つのMammalオブジェクトのCryメソッドを呼んでいるが、
　実際に実行されるのは、Dog、Cat、CrowのMammal_Cryメソッドであることを示している。
　同一のCryというメッセージをMammalオブジェクトに通知しているが、
　受け取った各々のオブジェクト毎に異なった動作をしていることになる。（多態性（ポリモフィズム））
[サンプルコード]

コードのコピー

Option Explicit '[クラス名] Mammalクラス '[説明] 哺乳類を表すクラス '       Dog（イヌ）、Cat（ネコ）、Crow（カラス）の '       親クラスとして利用 '[メソッド名] '   Cry '[機能] '   動物の鳴き声を取得します。 '[前提条件] '   子クラスでオーバーライドして下さい。 Function Cry() As String     Err.Raise _         999, , _         "このクラスのメソッドは直接呼ぶことはできません。" & vbCrLf & _         "子クラスでオーバーライドして呼んで下さい。"  End Function

[ExcelVBA]Mammalクラス

コードのコピー

Option Explicit '[クラス名] Dogクラス '[説明] イヌを表すクラス 'Mammalクラスを実装 Implements Mammal '[メソッド名] '   Mammal_Cry '[機能] '   動物の鳴き声を取得します。 '[備考] '   メソッド名は、「親クラス名」_「メソッド名」 Public Function Mammal_Cry() As String     Mammal_Cry = "ワンワン" End Function

[ExcelVBA]Dogクラス

コードのコピー

Option Explicit '[クラス名] Catクラス '[説明] ネコを表すクラス 'Mammalクラスを実装 Implements Mammal '[メソッド名] '   Mammal_Cry '[機能] '   動物の鳴き声を取得します。 '[備考] '   メソッド名は、「親クラス名」_「メソッド名」 Public Function Mammal_Cry() As String     Mammal_Cry = "ニャー" End Function

[ExcelVBA]Catクラス

コードのコピー

Option Explicit '[クラス名] Crowクラス '[説明] カラスを表すクラス 'Mammalクラスを実装 Implements Mammal '[メソッド名] '   Mammal_Cry '[機能] '   動物の鳴き声を取得します。 '[備考] '   メソッド名は、「親クラス名」_「メソッド名」 Public Function Mammal_Cry() As String     Mammal_Cry = "カァーカァー" End Function

[ExcelVBA]Crowクラス

コードのコピー

Private Sub CommandButton1_Click()     '哺乳類のオブジェクト変数を宣言     '要素数３つの配列を用意     Dim man(2) As Mammal          'イヌ、ネコ、カラスの     'オブジェクトを生成     Set man(0) = New Dog     Set man(1) = New Cat     Set man(2) = New Crow          '各々の動物の鳴き声を表示     MsgBox man(0).Cry()     MsgBox man(1).Cry()     MsgBox man(2).Cry()     'オブジェクトを解放     Set man(0) = Nothing     Set man(1) = Nothing     Set man(2) = Nothing End Sub

[ExcelVBA]呼び出し元

[実行結果]

タグ：Excel VBA オブジェクト指向 多態性 ポリモーフィズム