Personsクラスの改良
Personsクラスの改良
前回
のPersonsクラスをちょこっとだけ改良する。
PersonsクラスのextractNamesメソッドは、その名のとおりPersonインスタンスのNameプロパティの値だけを指定したセルを開始位置として転記するものだった。
これを、Personインスタンスが持つ三つのデータ（Name、BirthPlace、BelongsTo各プロパティの値。）を転記するように改める。
Personsクラスのコードの修正
PersonsクラスのextractNamesメソッドの名前をextractDataとし、中身を次のように書き換える。宣言セクションに列挙体を追加した関係で、クラスモジュール全体を掲載する。
Personsクラス
Option Explicit 'Constants' Private Enum PersonsData psdName = 1 psdBirthPlace psdBelongsto End Enum 'Module Level Variables' Private items_ As New Collection 'Properties' Public Property Get Items() As Collection Set Items = items_ End Property 'Methods' Public Sub addItem(ByVal name__ As String, _ ByVal birthPlace__ As String, _ ByVal belongsTo__ As String) Dim newPerson As New Person Call newPerson.init(name__, birthPlace__, belongsTo__) Call items_.Add(newPerson) End Sub Public Sub removeItem(ByVal indexNumber As Long) Call items_.Remove(indexNumber) End Sub Public Sub extractData(ByVal targetLeftTop As Range) Const DATA_COUNT As Long = 3 Dim i As Long Dim ar() As String ReDim ar(1 To items_.Count, 1 To DATA_COUNT) For i = 1 To items_.Count With items_(i) ar(i, psdName) = .Name ar(i, psdBirthPlace) = .BirthPlace ar(i, psdBelongsto) = .BelongsTo End With Next Dim targetRange As Range Set targetRange = targetLeftTop.Resize(items_.Count, DATA_COUNT) targetRange.Value = ar End Sub
各Personインスタンスの諸データを２次元配列に格納するForループ内で、２次元目のインデックスを指定するときにreadableになるように、列挙体PersonsDataを定義した。
あと、２次元目の上限値の指定がマジックナンバーになってしまうので、メソッド冒頭で定数（DATA_COUNT）にしている。
将来、Personクラスのプロパティが増えたときには、この値を変更すれば良い。
また、Personクラスのプロパティ数（データの種類）を、他のメソッド等で使用するような事態になったら、この定数をProcedure LevelからModule Levelにしたら良い。
実行
シート上のコマンドボタンに、次のプロシージャを登録して実行してみる。
M01ModuleMainモジュール
Private Sub testPersonClass()
Dim i As Long
With Sh01Master.NameList
For i = 1 To .Rows.Count
Call Persons.addItem(.Cells(i, sh01icName).Value, _
.Cells(i, sh01icBirthPlace).Value, _
.Cells(i, sh01icBelongsTo).Value)
Next
For i = 1 To Persons.Items.Count
Call Persons.Items(i).introduceMyself( _
.Cells(i, sh01icEntranceSide).Value, _
.Cells(i, sh01icWrestlerRank).Value)
Next
End With
Call Persons.extractData(Sh02Extracted.StartCell) '……(*)'
Sh02Extracted.NameList.Borders.LineStyle = xlContinuous
Set Persons = Nothing
End Sub
前回から変えたのは(*)のところだけ。変えたっつってもメソッド名の変更に追随しただけですけど。
オブジェクト指向の良いところは、このように呼び出し側を変更する必要がない、というところですね。
このとおり。
おわりに
まあ、同様のことはPersonオブジェクトの配列でも実現できるんですけど、データの抽出とか転記、といった処理をクラスの中に閉じ込めることができる、というのは結構なメリットかも。
抽出とか転記の処理を書くこと自体は簡単だけれど、毎回毎回となると結構めんどくさいんで。
PersonクラスとPersonsクラス
PersonクラスとPersonsクラス
TwitterのTL上で見かけたので、中途半端に乗っかってみる。
準備
Excelのブックに二つのワークシートを準備して、片や「MasterData」（オブジェクト名は「Sh01Master」）、こなた「Extracted」（オブジェクト名は「Sh02Extracted」）と名づけた。
それぞれのシートは次のとおり。
また、標準モジュール三つ（「M00PublicVariables」、「M01ModuleMain」、「XlsCommon」）、クラスモジュール二つ（「Person」、「Persons」）を置いた。
プロジェクト・エクスプローラーは、
この状態。
コード
ひとまず、モジュールごとにコードを示す。
シートモジュール
Sh01Masterモジュール
Option Explicit 'Constants' Public Enum Sh01InfoColumn sh01icName = 1 sh01icBirthPlace sh01icBelongsTo sh01icEntranceSide sh01icWrestlerRank End Enum Public Property Get NameList() As Range Dim rng As Range Set rng = Me.Range("A1").CurrentRegion With rng Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, _ .Columns.Count) End With Set NameList = rng End Property
シート上の表の列番号を指す列挙体と、表の正味のデータ部分を返すプロパティ（NameList）を置いた。
Sh02Extractedモジュール
Option Explicit
Public Property Get NameList() As Range
Dim rng As Range
Set rng = Me.Range("A1").CurrentRegion
rng.Borders.LineStyle = xlNone
Set NameList = rng
End Property
Public Property Get StartCell() As Range
Dim startRow As Long
startRow = Me.Cells(Me.Rows.Count, 1).End(xlUp).Row + 1
Set StartCell = Me.Cells(startRow, 1)
End Property
A1セルを基準とするアクティブセル領域を取得するプロパティ（NameList）と、その領域の直後のセルを取得するプロパティ（StartCell）を置いた。
このセル範囲には、後述するPersonオブジェクトのNameプロパティの値の転記先として用いる。
クラスモジュール
Personクラス
Option Explicit
'Module Level Variables'
Private name_ As String
Private birthPlace_ As String
Private belongsTo_ As String
'Properties'
Public Property Get Name() As String
Name = name_
End Property
Public Property Get BirthPlace() As String
BirthPlace = birthPlace_
End Property
Public Property Get BelongsTo() As String
BelongsTo = belongsTo_
End Property
'Constructor'
Public Sub init(ByVal name__ As String, _
ByVal birthPlace__ As String, _
ByVal belongsTo__ As String)
name_ = name__
birthPlace_ = birthPlace__
belongsTo_ = belongsTo__
End Sub
'Methods'
Public Sub introduceMyself(ByVal entranceSide As String, _
ByVal wrestlerRank As String)
Call XlsCommon.makeUserSick( _
entranceSide & " " & wrestlerRank & " " & _
name_ & vbCrLf & _
birthPlace_ & "出身 " & belongsTo_)
End Sub
三つのプロパティ（「Name」、「BirthPlace」、「BelongsTo」）とコンストラクタ、後は自己紹介メソッド（introduceMyself）を置いた。
追記
改めて見直すと、これはうまくないなあ。
PersonクラスからXlsCommonモジュールのメソッドを呼び出しているのでは、依存関係ができてしまっている。どうせmakeUserSickメソッドしか使わないのだから、Personクラス内に封印してしまわないと……。
またヒマなときに修正します。
*****追記ここまで*****
Personsクラス
Option Explicit
'Module Level Variables'
Private items_ As New Collection
'Properties'
Public Property Get Items() As Collection
Set Items = items_
End Property
'Methods'
Public Sub addItem(ByVal name__ As String, _
ByVal birthPlace__ As String, _
ByVal belongsTo__ As String)
Dim newPerson As New Person
Call newPerson.init(name__, birthPlace__, belongsTo__)
Call items_.Add(newPerson)
End Sub
Public Sub removeItem(ByVal indexNumber As Long)
Call items_.Remove(indexNumber)
End Sub
Public Sub extractNames(ByVal startFrom As Range)
Dim i As Long
Dim ar() As String
ReDim ar(1 To items_.Count, 1 To 1)
For i = 1 To items_.Count
ar(i, 1) = items_(i).Name
Next
Dim targetRange As Range
Set targetRange = startFrom.Resize(items_.Count, 1)
targetRange.Value = ar
End Sub
Personインスタンスを格納するCollection型のプロパティ（「Items」）を置いた。
あと、Personインスタンスを追加するaddItemメソッド、削除するremoveItemメソッドに加え、指定したセルを先頭に、Itemに格納されているPersonインスタンスのNameプロパティの値をずらり並べて書き込むextractNamesメソッドを置いた。
標準モジュール
M00PublicVariablesモジュール
Option Explicit 'Public Variable' Public Persons As New Persons
Personsオブジェクトは一つで良いので、Public指定で置いておく。これで、いつでもどこからでも使える。
M01ModuleMainモジュール
Option Explicit
Private Sub testPersonClass()
Dim i As Long
With Sh01Master.NameList
For i = 1 To .Rows.Count
Call Persons.addItem(.Cells(i, sh01icName).Value, _
.Cells(i, sh01icBirthPlace).Value, _
.Cells(i, sh01icBelongsTo).Value)
Next
For i = 1 To Persons.Items.Count
Call Persons.Items(i).introduceMyself( _
.Cells(i, sh01icEntranceSide).Value, _
.Cells(i, sh01icWrestlerRank).Value)
Next
End With
Call Persons.extractNames(Sh02Extracted.StartCell)
Sh02Extracted.NameList.Borders.LineStyle = xlContinuous
Set Persons = Nothing
End Sub
Personクラス、Personsクラス使用実験用コード。
同じ変数iを二つの異なる用途に使い回しているところはスルーでｗ
一つ目のForループで、「MasterData」シート上のデータ（笑）に基づいてPersonインスタンスをPersonsクラスのItemsにぶち込む。
二つ目のForループでは、Itemsコレクションの中身を取り出して、それぞれintroduceMyselfメソッドを実行。
最後に、PersonsクラスのextractNamesメソッドを用いて、それぞれのPersonインスタンスのNameプロパティの値を「Extracted」シートのA列に転記する。
XlsCommonモジュール
※必要な部分のみ掲載します。
'Constants'
Private Const MAKE_USER_SICK_2013 As String = _
" ＿＿＿＿＿＿＿" & vbCrLf & _
" ／ ＼" & vbCrLf & _
"／ ／・＼ ／・＼ ＼" & vbCrLf & _
"| ￣￣ ￣￣ | ち～んｗ" & vbCrLf & _
"| （＿人＿） |" & vbCrLf & _
"| ＼ | |" & vbCrLf & _
"＼ ＼_| ／"
Private Const MAKE_USER_SICK_2010 As String = _
" ＿＿＿＿＿＿＿" & vbCrLf & _
" ／ ＼ " & vbCrLf & _
"／ ／・＼ ／・＼ ＼" & vbCrLf & _
"| ￣￣ ￣ | ち～んｗ" & vbCrLf & _
"| （＿人＿） |" & vbCrLf & _
"| ＼ | |" & vbCrLf & _
"＼ ＼＿| ／"
Public Sub makeUserSick(Optional ByVal msg As String)
Dim ver As String
ver = Application.Version
Dim str As String
Select Case ver
Case "14.0"
str = MAKE_USER_SICK_2010
Case "15.0"
str = MAKE_USER_SICK_2013
Case "16.0"
str = MAKE_USER_SICK_2013
Case Else
str = MAKE_USER_SICK_2010
End Select
If msg = "" Then msg = "涙拭けよｗｗｗ"
MsgBox msg & vbCrLf & str
End Sub
当ブログではおなじみ、makeUserSickメソッド。
単にメッセージを表示するだけだが、無駄にむかつく顔文字を添える。
実験
「Extracted」シート上にコマンドボタンを置き、M01ModuleMainモジュールのtestPersonClassメソッドを登録して実行する。
こんな感じ。
おわりに
意外と楽しかった。
２次元配列の値をRangeオブジェクトに突っ込むときの配列はVariantでなくても良い(Excel)
２次元配列の値をRangeオブジェクトに突っ込むときの配列はVariantでなくても良い
初歩的過ぎますか？
２次元配列の値を一気にRangeオブジェクトに書き込む処理は、Variant型の変数を使う例が多かったので、全然気づいていませんでした。
実験
シートモジュールに、次のようなコードを書いてみた。
リスト１ シートモジュール
Private Property Get TestArea() As Range
Set TestArea = Me.Range("$D$1:$G$6")
End Property
Private Sub write2DimensionArray( _
ByVal targetRange As Range)
With targetRange
Dim rowSize As Long
rowSize = .Rows.Count
Dim colSize As Long
colSize = .Columns.Count
End With
Dim arr() As String
ReDim arr(1 To rowSize, 1 To colSize)
Dim r As Long
Dim c As Long
For r = 1 To rowSize
For c = 1 To colSize
arr(r, c) = "ち～んｗ"
Next
Next
targetRange.Value = arr
End Sub
シートにTestAreaというプロパティを設置。さらに、引数として渡したRangeオブジェクトの各セルに「ち～んｗ」という文字列を書き込むwrite2DimensionArrayというメソッドを作ってみた。
String型の２次元配列を作り、その値を書き込む、という処理。
実験
次のコードで、引数にTestAreaプロパティが返すRangeオブジェクトを指定してwrite2DimensionArrayメソッドを実行してみる。
リスト２
Private Sub testWrite2DimensionArray() Call write2DimensionArray(TestArea) End Sub
こいつを、シート上のコマンドボタンに登録して呼び出してみる。
フツーに書き込めている。
おわりに
まあ、考えたら当り前のことなのだが、「２次元配列からの転記のときはVariant」という先入観に囚われていた。
Rangeオブジェクトが矩形かどうかを判定する(Excel)
Rangeオブジェクトが矩形かどうかを判定する
Rangeオブジェクトに入っているセル範囲は、必ずしも連続した矩形領域であるとは限らない。
[Ctrl]を押しながら選択すれば、飛び地状態で選択できるし、飛び地状態で一つのRange型変数にぶちこむことだってできる。
連続した矩形領域でないRangeオブジェクトのAddressプロパティ
連続した矩形状態ではないRangeオブジェクトのAddressプロパティがどのような値を返すものなのか、調べてみた。
まずはこの状態。飛び地状態である。
イミディエイト・ウインドウに
?Selection.Addressと打ち込んで[Enter]してみると、
このとおり、二つの領域が「,」（カンマ）でつながれている。
今度はこの状態。連続してはいるものの、矩形領域ではない。
今度もこのとおり。やはり二つの矩形に分割して、それぞれのアドレスが「,」でつながれている。
つまり、
単一の矩形領域ならば、Addressプロパティの返り値に「,」がない
ということではないか！
コーディング
以上の考察をもとに、Function化する。
リスト１
Private Function isSingleRectangle( _ ByVal targetRange As Range) As Boolean isSingleRectangle = False Dim tmp As String tmp = targetRange.Address If InStr(1, tmp, ",") > 0 Then Exit Function isSingleRectangle = True End Function
追記
メソッド名を変えました。このメソッドで判定可能な矩形は、あくまでも単一の矩形領域なので。また、複数の領域が組み合わさってたまたま一つの矩形になっているように見える見かけ上の矩形領域を判定するような場面も思い浮かばないので、このようにしました。見かけ上の矩形領域も含めて矩形判定するメソッドも、いづれ頭の体操としてやってみたくはありますが……。
追記ここまで。
実に簡単。
引数で受け取ったRangeオブジェクトのAddressプロパティをInStr関数で調べ、「,」が含まれていたらFalseを返す。
それだけ。
実験
次のコードで実験。
リスト２
Private Sub testIsRectangle()
Dim rng As Range
Set rng = Selection
Dim msg As String
If isSingleRectangle(rng) Then _
msg = "矩形やんけｗｗｗ" Else msg = "矩形ちゃうやんけｗｗｗ"
Call XlsCommon.makeUserSick("選択範囲は" & msg)
End Sub
選択範囲について矩形判定をして、結果に応じたメッセージを表示する。
メッセージを表示するためのXlsCommon.makeUserSickメソッドについては、
コチラをどうぞ。
シート上のコマンドボタンにリスト２のマクロを登録して実行する。
バッチリ。
おわりに
今回は、ExcelVBAの機能に丸ごと乗っかっただけなので、あまりプログラミング的な解決ではない。
一度頭の体操に、もっと原始的な矩形判定プログラムをつくってみたい。
シートオブジェクトにPropertyを生やそう！
シートモジュールにPropertyを生やそう！
シートモジュールにPropertyを設置すると便利、というだけの話。
準備
たとえば、ワークシート（オブジェクト名は「Sheet1」）上に、次のようなリストがあるとする。
とりあえず超シンプルな表にした。
Propertyを設定する
このリスト部分を、Sheet1オブジェクトのPropertyにしてしまおう、という試み。
後々の拡張性も考えて、次のような仕様にした。
仕様
- 列数は定数で指定
- 行数は伸び縮みすることを見越して指定列の最終セルをその都度取得
以上。
コーディング
Sheet1モジュールに次のようにコードを書く。
リスト１ Sheet1モジュール
Option Explicit
'Constants'
'リスト領域の列数'
Private Const LIST_AREA_WIDTH As Long = 4
'リスト左上端のセルアドレス'
Private Const LEFTTOP_ADDRESS As String = "A1"
Public Property Get ListAreaRange( _
Optional ByVal targetColumn As Long) As Range
'引数省略時は「1」にする。'
If targetColumn = 0 Then targetColumn = 1
'一旦基準セルを変数に格納。'
Dim rng As Range
Set rng = Me.Range(LEFTTOP_ADDRESS)
'リストのタテ方向のサイズを取得。'
Dim verticalSize As Long
verticalSize = Me.Cells(Me.Rows.Count, targetColumn).End(xlUp).Row
verticalSize = verticalSize - Me.Range(LEFTTOP_ADDRESS).Row + 1
'変数rngをリサイズする。'
Set rng = rng.Resize(verticalSize, LIST_AREA_WIDTH)
Set ListAreaRange = rng
End Property
リストの列数と、左上端セルのアドレスは、定数で指定している。変更があった場合は書き換えればよい。
Property Getプロシージャ内での処理はコメントのとおり。なるべく変更に強い書き方を試みた。
リスト最終行の取得は、おなじみのEndプロパティを用いるやり方にしたが、気に入らなければ他のやり方にしたら良いと思う。
今回のようなリストなら、
Set ListAreaRange = Me.Range(LEFTTOP_ADDRESS).CurrentRegion
でも良いのだが、たとえば
このようなリストで、「会員番号」の欄にあらかじめ値が入っていて、２列目以降にデータを抽出してきて表を完成させるような場合、CurrentRegionプロパティを使うやり方では不要な部分まで全部取得してしまうので、今回のようなやり方にした。
実験
イミディエイト・ウインドウに
?Sheet1.ListAreaRange.Addressと打ち込んで[Enter]！
バッチリ！
おわりに
シートのよく使う部分については、こんなふうにPropertyを生やしておくと便利だし、命名次第では非常にreadableになるのでオススメです。
処理の手順をコーディングするのではなく、シートオブジェクトの機能としてオブジェクトに封印してしまい、それを利用するだけ、というのはオブジェクト指向的なアプローチでもあると思う。
Switch関数はRangeオブジェクトを返すのか
Switch関数はRangeオブジェクトを返すか
前回
初めてその存在を知ったSwitch関数。
こいつは、たとえばRangeオブジェクトを返したりすることはできるのだろうか。
やってみた。
準備
Sheet1オブジェクトに次のようなPropertyを実装してみる。
リスト１ Sheet1モジュール
Option Explicit Public Enum ProvocationType ptTypeA ptTypeB ptTypeC End Enum Friend Property Get ProvocationCell( _ ByVal typeOfProvocation As ProvocationType) As Range Dim tmp As ProvocationType tmp = typeOfProvocation Dim ret As Range Set ret = Switch(tmp = ptTypeA, Me.Range("A1"), _ tmp = ptTypeB, Me.Range("A2"), _ tmp = ptTypeC, Me.Range("A3")) Set ProvocationCell = ret End Property
自作のProvocationCellプロパティの引数に、自作列挙体ProvocationTypeを指定。
Propertyプロシージャ内部では、引数で受け取ったProvocationType列挙体の値（ptTypeA～ptTypeC）によって、Switch関数の返り値をＡ１セル～Ａ３セルに切り替えるようにしている。
特に逐次コンパイルに引っかかることもなかったので、普通にRangeオブジェクトを返しそう。
ワクワク感が止まらない！
ちなみに、Sheet1はこの状態。
実験
標準モジュールに次のコードを書いて実験。
リスト２ 標準モジュール
Private Sub testSwitchFunctionReturnRange() Call MsgBox(Sheet1.ProvocationCell(ptTypeA).Value) Call MsgBox(Sheet1.ProvocationCell(ptTypeB).Value) Call MsgBox(Sheet1.ProvocationCell(ptTypeC).Value) End Sub
Sheet1オブジェクトの自作ProvocationCellプロパティを、引数を変えながら参照し、取得したRangeオブジェクトのValueプロパティの値をメッセージボックスに表示させるだけのコード。
ご覧のとおり。
おわりに
ちゃんとRangeオブジェクトも返してくれる。
簡単な条件分岐なら、Select Caseを使わずとも簡単に書けそう。
Switch関数というものがある
Switch関数というものがある
知ってました？
私は全然知らなかった。
何気なく『Programming Excel with VBA and .NET』という本を読んでいたら、59ページに、
Sub GetResponse() ' Declare variable as an enumerated value' Dim res As VbMsgBoxResult ' Get the response.' res = MsgBox("What's your response?", vbYesNoCancel) ' Test the response against possible values.' Debug.Print "Response is:", Switch(res = vbYes, "Yes", _ res = vbNo, "No", res = vbCancel, "Cancel") End SubIn the preceding code, the variable
rescan contain any of the possible message box results.TheSwitchfunction compares the variable to each of the possible responses to display an appropriate string in the Immediate window.
と書いてあった。
マ、マジっすか……？！
全然知らなかったよ！
実験
標準モジュールに次のコードを書いて実験。
リスト１ 標準モジュール
Private Sub getResponse()
Dim userRes As VbMsgBoxResult
userRes = MsgBox("どれか選べやｗｗｗ", vbYesNoCancel)
Debug.Print Switch(userRes = vbYes, "ち～んｗ", _
userRes = vbNo, "( ´,_ゝ｀)ﾌﾟｯ", _
userRes = vbCancel, "(ﾟ∀ﾟ)ｱﾋｬ")
End Sub
こいつを何度も実行し、その都度返答を変えてみる。
いざ、実行！
ほ、ほんまや……。
おわりに
何か、使いどころはあるかなあ。
小ネタでした。
