テキストファイルの内容を保持するクラス
テキストファイルの内容を保持するクラス
処理に必要な値の中で、〈ほぼ静的なんだけどちょっと動的な値〉、つまり、滅多に変更することはないのだけれど、たまに変更が生ずるような値があると、実にめんどくさい。
これがExcelの場合だと、設定値書き込み用のシートを置いておけば、そのシートを設定ファイル代わりに使えて便利だ。
しかし、WordやPowerpointなどだとそうはいかない。
まあ、〈滅多に変更することがない値〉なので、モジュールに定数として書いてしまう、という対応をよくする。
実用上、これで困ることはほぼないのだが、それでもやはりたまに訪れる変更のときに、いちいちVBEを開いて書き換える、というのもイマイチな気がする。
ほかには、たとえば、CustomDocumentPropertiesを用いるという手もあるが、それとていちいちDocumentなりPresentationなりを開かねばならんので、やはりめんどくさい。
そこで、テキストファイルですよ！
テキストファイルを用いる
プロジェクトの外側に設定用のテキストファイルを置いておけば、設定変更したいときはそのテキストファイルを書き換えれば済むのだから、ユーザとしてはずいぶん楽になる。
しかし、コーディングという観点からすれば、VBAからテキストファイルを操るのは、（めったに使わないステートメントを使わねばならんこともあって）かなりめんどくさい。
それならば、クラスでラップしちまえば良いのですよ。
TextFileクラス
テキストファイルの各行の文字列をインスタンス内に保持して、必要に応じて対象行の文字列を返すシンプルなクラスにしてみた。
とりあえず、書いたコードをぶちまける。
クラスモジュール TextFile
Option Explicit 'Constants' Private Enum ErrorTypes etFileNotFound = 1 etLineNotExists etErrorOccurred End Enum 'Module Level Variables' Private fileFullName As String Private line_() As String Private fsObj As FileSystemObject 'Properties' Public Property Get Line(ByVal numberOf As Long) As String Const ERR_SOURCE As String = "TextFile Class, Property Get Line" Dim ret As String '存在しない行番号を指定していたらエラー。' If UBound(line_) + 1 < numberOf Or _ numberOf < 0 Then _ Call raiseError(etLineNotExists, ERR_SOURCE) On Error GoTo ErrorHandler ret = line_(numberOf - 1) Line = ret Exit Property ErrorHandler: '何かしらエラーが出たら、イミディエイトに情報を表示して中断。' Debug.Print "Number : " & Err.Number Debug.Print "Description : " & Err.Description Call raiseError(etErrorOccurred, "") End Property Public Property Get LineCount() As Long Dim ret As Long If IsEmpty(line_) Then ret = 0: GoTo Finalizer ret = UBound(line_) + 1 Finalizer: LineCount = ret End Property 'Constructors' Private Sub Class_Initialize() Set fsObj = New FileSystemObject End Sub Public Sub init(ByVal targetFullName As String) '対象ファイルの存否確認。なければエラー。' If Not fsObj.FileExists(targetFullName) Then _ Call raiseError(etFileNotFound, "TextFile Class, init Method") 'モジュールレベル変数に対象ファイルのフルパスを保存' fileFullName = targetFullName 'テキストファイルを開いて、データを取得' Dim n As Long n = FreeFile(0) Open fileFullName For Input As n Dim LineCount As Long LineCount = 1 Do ReDim Preserve line_(LineCount - 1) Line Input #n, line_(LineCount - 1) LineCount = LineCount + 1 Loop Until EOF(n) Close n End Sub 'Destructor' Private Sub Class_Terminate() Set fsObj = Nothing End Sub 'Methods' Public Sub regetData(Optional ByVal targetFullName As String) If targetFullName = "" Then GoTo MainProcess If Not fsObj.FileExists(targetFullName) Then _ Call raiseError(etFileNotFound, "TextFile Class, regetData Method") '新たにファイルフルパスが渡されたら、それを新しいファイルフルパスにする' fileFullName = targetFullName MainProcess: Erase line_ Call Me.init(fileFullName) End Sub Private Sub raiseError(ByVal typeOfError As ErrorTypes, _ Optional ByVal errorSource As String) Dim msg As String msg = getErrorMessage(typeOfError) Call Err.Raise(Number:=10000 + typeOfError, _ Source:=errorSource, _ Description:=msg) End Sub Private Function getErrorMessage( _ ByVal typeOfError As ErrorTypes) As String Dim ret As String Select Case typeOfError Case etFileNotFound: ret = "The file you specified isn't found." Case etLineNotExists: ret = "This file doesn't have so many lines." Case etErrorOccurred: ret = "Some Error has occurred" End Select getErrorMessage = ret End Function
パーツごとに見ておこう。
Constants
Private Enum ErrorTypes etFileNotFound = 1 etLineNotExists etErrorOccurred End Enum
クラス内でエラーが起こった場合の対応を分岐するために、列挙体を作った。
この値に応じてgetErrorMessageメソッドでエラーメッセージを取得して、raiseErrorメソッドでエラーを起こすのに使う。
Module Level Variables
Private fileFullName As String Private line_() As String Private fsObj As FileSystemObject
クラスモジュール内で通用するモジュールレベル変数。
fileFullNameには、テキストファイルのフルパスを保存する。
line_()には、テキストファイルから読み込んだ文字列を、配列にしてぶちこんでおく。
fsObjは、FileSystemObjectのインスタンス用。ファイルやフォルダの存否確認に必ず用いるので、クラス内にPrivateで置いておく。
Properties
Public Property Get Line(ByVal numberOf As Long) As String
Const ERR_SOURCE As String = "TextFile Class, Property Get Line"
Dim ret As String
'存在しない行番号を指定していたらエラー。'
If UBound(line_) + 1 < numberOf Or _
numberOf < 0 Then _
Call raiseError(etLineNotExists, ERR_SOURCE)
On Error GoTo ErrorHandler
ret = line_(numberOf - 1)
Line = ret
Exit Property
ErrorHandler:
'何かしらエラーが出たら、イミディエイトに情報を表示して中断。'
Debug.Print "Number : " & Err.Number
Debug.Print "Description : " & Err.Description
Call raiseError(etErrorOccurred, "")
End Property
Public Property Get LineCount() As Long
Dim ret As Long
If IsEmpty(line_) Then ret = 0: GoTo Finalizer
ret = UBound(line_) + 1
Finalizer:
LineCount = ret
End Property
プロパティはとりあえず二つだけ。
Lineプロパティは、対象のテキストファイルの文字列の内、引数で指定した行の文字列を返す。
変な引数が与えられたときにはエラーを起こすようにしている。
LineCountプロパティは、テキストファイルの行数を返す。
とりあえずはこれだけ。
Constructors
Private Sub Class_Initialize()
Set fsObj = New FileSystemObject
End Sub
Public Sub init(ByVal targetFullName As String)
'対象ファイルの存否確認。なければエラー。'
If Not fsObj.FileExists(targetFullName) Then _
Call raiseError(etFileNotFound, "TextFile Class, init Method")
'モジュールレベル変数に対象ファイルのフルパスを保存'
fileFullName = targetFullName
'テキストファイルを開いて、データを取得'
Dim n As Long
n = FreeFile(0)
Open fileFullName For Input As n
Dim LineCount As Long
LineCount = 1
Do
ReDim Preserve line_(LineCount - 1)
Line Input #n, line_(LineCount - 1)
LineCount = LineCount + 1
Loop Until EOF(n)
Close n
End Sub
コンストラクタに引数を渡すことができないVBAの悲しい性により、コンストラクタが二つもある。
一つ目はFileSystemObjectのインスタンスをfsObjにぶち込むだけ。必ず使用するのだから、ここでセットしておくのが良いと思った。
もう一つのinitメソッドがこのクラスの中枢部分。
テキストファイルから各行の文字列を取り出して配列に格納。
データの抜き出しが終わったら、テキストファイルは用無しなので、閉じてしまう。必要ならまた開けば良い。
Destructor
Private Sub Class_Terminate() Set fsObj = Nothing End Sub
これはまあ、FileSystemObjectのインスタンスを破棄しているだけ。別にいらんといえばいらんけど。
Methods
Public Sub regetData(Optional ByVal targetFullName As String)
If targetFullName = "" Then GoTo MainProcess
If Not fsObj.FileExists(targetFullName) Then _
Call raiseError(etFileNotFound, "TextFile Class, regetData Method")
'新たにファイルフルパスが渡されたら、それを新しいファイルフルパスにする'
fileFullName = targetFullName
MainProcess:
Erase line_
Call Me.init(fileFullName)
End Sub
Private Sub raiseError(ByVal typeOfError As ErrorTypes, _
Optional ByVal errorSource As String)
Dim msg As String
msg = getErrorMessage(typeOfError)
Call Err.Raise(Number:=10000 + typeOfError, _
Source:=errorSource, _
Description:=msg)
End Sub
Private Function getErrorMessage( _
ByVal typeOfError As ErrorTypes) As String
Dim ret As String
Select Case typeOfError
Case etFileNotFound: ret = "The file you specified isn't found."
Case etLineNotExists: ret = "This file doesn't have so many lines."
Case etErrorOccurred: ret = "Some Error has occurred"
End Select
getErrorMessage = ret
End Function
メソッドは今のところ三つ。
とはいえ、最後のgetErrorMessageメソッドはraiseErrorメソッドの下請けみたいなもんなので、実質二つ。
しかも、raiseErrorメソッドは、エラーが出たときの内部メソッドに過ぎないので、実質は一つみたいなもん。
で、その唯一のregetDataメソッドは、テキストファイルからのデータ再取得メソッド。
将来的に、このTextFileクラスを介してテキストファイルを書き換えるようなメソッドを置いたような場合に、設定の再取得ができるように作っただけ。今のところ使い道はない。
実験
次のようなテキストファイルを用意する。
マクロを実行するプロジェクト（今回はWord VBAを使うので、Wordドキュメント。）と同じフォルダ内に、「Test.txt」という名前にして置いておく。
そうして、次のコードで実験。
リスト２ 標準モジュール
Private Sub testTextFileClass()
Dim targetPath As String
targetPath = ThisDocument.Path & "\" & "test.txt" '"
Dim txtFile As TextFile
Set txtFile = New TextFile
Call txtFile.init(targetPath)
Dim i As Long
For i = 1 To txtFile.LineCount
Debug.Print txtFile.Line(i)
Next
Call txtFile.regetData(targetPath)
For i = 1 To txtFile.LineCount
Debug.Print txtFile.Line(i)
Next
End Sub
TextFileクラスのインスタンスを生成し、「Test.txt」のフルパスを渡して初期化。
Lineプロパティの中身を全てイミディエイト・ウインドウに吐き出させる。
その後、regetDataメソッドで再度「Test.txt」のデータを読み込んで、Lineプロパティの中身を全てイミディエイト・ウインドウに吐き出させる。
もちろん、「Test.txt」の中身は変わらないので、同じ出力が二度あるだけだが。
実行結果
意図どおり。
おわりに
クラスにしたので、設定ファイルが複数種類あっても、それぞれインスタンスを作ればよい。
また、たとえば、
テキストファイルの１行目が保存用フォルダ名、２行目が差込印刷データソースのファイル名、３行目が差込データテーブルの名前
だったら、呼び出し側のモジュールに
Private Enum SettingData sdSaveFolderName = 1 sdDataSourceFileName sdDataSourceTableName End Enum
のような列挙体を作成しておき、
txtFile.Line(sdSaveFolderName)
のような形で呼び出すようにすれば、非常にreadableになると思う。
追記
TextFileクラスは新しくなりました。(2019/07/17)
さらに追記
今はこんなことになっています。
指定した文字列に傍点を施すWordマクロ
指定した文字列に傍点を施すWordマクロ
芦田宏直氏が、ブログ『芦田の毎日』上で、「シラバスとは何か ― コマシラバスはなぜ必要なのか」という超大作の論考を発表しておられる。
氏のツイート（@jai_an）によると、2019/07/06時点で11万字overとのこと。
読むにあたっての困難
読まねば、とは思ったものの、何せ11万字overの論考である。
素人ゆえ大した読解力もない私が、PCやタブレットの画面上で読むのはつらい。
とりあえず、Wordとか一太郎にコピペしてプリントアウトし、紙で読もうと思った。
しかし、そこでちょっと困ったことに気づいた。
これである。
文中のところどころに(●●●●)のような、カッコでくくったハナクソが大量にあるのである。
最初は何かのミスだと思ったのだが、よくよく読んでみると、
直前の文字列に傍点があるというサイン
らしい。
つまり、
こういうことだ。
しかし、文中のあちこちにハナクソみたいな記号群があると、読みにくくて仕方がない。
何とかマクロで整形できないものか、考えてみた。
先に断っておくが、今のところまったく実用性のないソリューションになっているので、期待しないように。
コード
とりあえず、作成したコードをぶちまけておく。
リスト１ 標準モジュール
Option Explicit Private Sub main() Call putEmphasisMarkToDocument Call removeMarks End Sub Private Sub putEmphasisMarkToDocument() Dim doc As Document Set doc = ThisDocument Dim i As Long Dim targetCount As Long Dim hasStarted As Boolean Dim startPos As Long Dim endPos As Long For i = 2 To doc.Characters.Count 'カウントモード中に「●」に出会ったら、targetCountをインクリメントする' If hasStarted Then _ If doc.Characters(i) = "●" Then targetCount = targetCount + 1 'カウントモード中に「)」に出会ったら、startPosを確定させて傍点を施す' If hasStarted Then If doc.Characters(i) = ")" Then startPos = endPos - targetCount + 1 Call putEmphasisMark(doc, startPos, endPos) 'カウントモード解除' hasStarted = False End If End If 'カウントモード中は「(●」を探す必要なし' If hasStarted Then GoTo Continue Dim tmp As String tmp = doc.Characters(i - 1).Text & doc.Characters(i).Text '「(●」を見つけたら、targetCountを初期化し、カウントモードにした上で、' 'endPosの値を決める' If tmp = "(●" Then _ targetCount = 1: hasStarted = True: endPos = i - 2 Continue: Next End Sub '指定された文字に傍点を施す' Private Sub putEmphasisMark(ByVal targetDoc As Document, _ ByVal startPos As Long, _ ByVal endPos As Long) Dim i As Long For i = startPos To endPos targetDoc.Characters(i).EmphasisMark = wdEmphasisMarkOverComma Next End Sub '元の印（「(●●●)」）を削除する' Private Sub removeMarks() Dim orgRange As Range Set orgRange = Selection.Range Dim doc As Document Set doc = ThisDocument Call doc.Range(0, 0).Select Do With Selection.Find .MatchWildcards = False .MatchFuzzy = False .Text = "(●" Call .Execute If Not .Found Then Exit Do End With Call Selection.Collapse(Direction:=wdCollapseStart) With Selection Call .Extend(Character:=")") Call .Delete End With Loop Call orgRange.Select End Sub
もう、恥ずかしくなるぐらいの力業。強引にもほどがある。
[Document].Charactersコレクションを総当たりにしているので、11万字overのドキュメントにこのマクロを実行したら、当分終わらないだろうと思う。
一応説明しておくと、次のような手順で傍点を施している。
- 文書の先頭から１文字づつ当たっていき、「(●」になっているところを探す。
- 見つかったら、カウントモードをオンにする。（
hasStartedをTrueにする。） - 同時に、傍点を施す最後の文字の位置が分かるので、
endPosにセットする。 - 引き続き１文字づつ当たっていく。「●」である限り、
targetCountをインクリメントする。 - 「)」に当たったら、その時点での
targetCountの値が傍点を施すべき文字数。これで、傍点を施す開始位置が判明するので、startPosにセットする。 - 傍点を施すべき
Charactersコレクションの開始インデックス（startPos）と終了インデックス（endPos）が分かっているので、それぞれの要素のEmphasisMarkプロパティを設定する。
今改めて書き起こしても、実に強引なやり方だ……。
一通り傍点を施し終わったら、あとはハナクソ軍団を削除するのみ。
WordVBAについてはまだまだよくわかっていないので、こちらも強引な手法となった。簡単に手順を記しておくと、
Findオブジェクトを用いて、先頭から順に「(●」を探す。- 見つかったら、一旦始点側に選択範囲を潰す。
Selection.Extendメソッドを用いて選択範囲を広げる。引数Characterに「)」を渡すことにより、終端のカッコまで選択範囲を広げてくれる。- 先頭のカッコ～終端のカッコが選択された状態になるので、
Deleteメソッドを用いて削除する。 - 繰り返し。
まあ、こんな感じ。
実行
とりあえず、このような文書を用意して実験してみる。
とりあえず、意図した結果は得られている。
おわりに
しかし、相手は11万字overである……。
もっとスマートな方法があるはずだよな……。
とりあえず、選択範囲を文字数単位で拡張するメソッドとか、ないものか。（←調べろ。）
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になるのでオススメです。
処理の手順をコーディングするのではなく、シートオブジェクトの機能としてオブジェクトに封印してしまい、それを利用するだけ、というのはオブジェクト指向的なアプローチでもあると思う。
