フォルダを作成するクラス
フォルダ作成クラス
任意のディレクトリに任意の名前のフォルダを作る
新規フォルダを作るときは、MkDir関数を使う。
まあ、それはそれでいいのだが、何かこう、作りっぱなし感があって気持ち悪い。
せっかくなので、FileSystemObjectの練習も兼ねて、
フォルダを作るついでにFolderオブジェクトを返り値とするようなメソッドを持たせるクラスを作ってみよう
と思い立った。
相変わらず、何の役に立つのかは分からんがw
フォルダを作るクラス
例によってクラスモジュールを挿入し、オブジェクト名を「FolderCreator」とした。
あ、参照設定で「Microsoft Scripting Runtime」にチェックを入れていますよ。
リスト1 クラスモジュールのコード
Option Explicit 'Fields' Private folderPath_ As String '……(1)' Private fsObject_ As FileSystemObject Private createdFolder_ As Folder 'Accessor' Public Property Get createdFolder() As Folder '……(2)' Set createdFolder = createdFolder_ End Property 'Constructor' 'Methods' Public Function init(ByVal rootPath As String, _ ByVal folderName As String) As Folder '……(3)' folderPath_ = rootPath & "\" & folderName '……(4)''" If Dir(folderPath_, vbDirectory) = "" Then '……(5)'"" MkDir (folderPath_) End If Set fsObject_ = CreateObject("Scripting.FileSystemObject") '……(6)'"" Set createdFolder_ = fsObject_.GetFolder(folderPath_) '……(7)' Set init = createdFolder_ '……(8)' End Function
(1)からの3行
Private folderPath_ As String Private fsObject_ As FileSystemObject Private createdFolder_ As Folder
で3つの変数を準備。
「folderPath_」は別にいらないと思うが、一応。後述するinitメソッドの引数を受け取って、新たに作成するフォルダのフルパスを入れるのに使う。
「fsObject」は、FileSystemObjectオブジェクト用の変数。
「createdFolder」に新たに作成したフォルダのFolderオブジェクトを入れる。
(2)の
Public Property Get createdFolder() As Folder Set createdFolder = createdFolder_ End Property
はアクセサメソッド。基本的に新しくできたFolderオブジェクトにだけアクセスできたら、フォルダ名とかフォルダパスなんかはFolderオブジェクトから取得できるので、これで十分だと思う。
(3)から始まるFunctionプロシージャ
Public Function init(ByVal rootPath As String, _ ByVal folderName As String) As Folder
は擬似的なコンストラクタ。
VBAのコンストラクタが引数を持たせられたらいいんだけど、それができないので、
クラスをNewしたら必ず直後にinitメソッドを呼ぶ
ということを決めて、擬似的なコンストラクタとして使う。
第1引数に新しくフォルダを作りたいディレクトリのフルパス、第2引数に新しいフォルダの名前を指定する。
ここからはinitメソッドの中身。
まず、(4)の
folderPath_ = rootPath & "\" & folderName
で新しく作りたいフォルダのフルパス文字列を合成する。
(5)からの3行、
If Dir(folderPath_, vbDirectory) = "" Then MkDir (folderPath_) End If
で同名のフォルダがなければ、MkDir関数でフォルダを作る。
で、(6)の
Set fsObject_ = CreateObject("Scripting.FileSystemObject")
でFileSystemObjectのインスタンスを生成して変数「fsObject」に格納。
(7)の
Set createdFolder_ = fsObject_.GetFolder(folderPath_)
では、さっそくFileSystemObjectオブジェクトのGetFolderメソッドを用いて(5)で作った(もしくはもともとあった)フォルダをFolderオブジェクトとして取得して変数「createdFolder」に格納。
んで、(8)の
Set init = createdFolder
によってFolderPickerオブジェクトをinitメソッドの返り値にしている。
FolderCreatorクラスの使用
下記のコードで使ってみる。
リスト2 標準モジュールのコード
Public Sub test01() Dim myFolderCreator As FolderCreator '……(1)' Set myFolderCreator = New FolderCreator '……(2)' Dim myFolder As Folder '……(3)' Set myFolder = myFolderCreator.init(ThisWorkbook.Path, "ち~んw") '……(4)'"" With myFolder '……(5)' Debug.Print .Drive Debug.Print .ParentFolder Debug.Print .Name Debug.Print .Path End With End Sub
(1)の
Dim myFolderCreator As FolderCreator
でFolderCreatorクラスのインスタンス用変数「myFolderCreator」を用意。
(2)の
Set myFolderCreator = New FolderCreator
で「myFolderCreator」にFolderCreatorクラスのインスタンスを格納。
(3)の
Dim myFolder As Folder
でinitメソッドの返り値(=新しく作られるFolderオブジェクト)を受ける変数を用意して、
(4)の
Set myFolder = myFolderCreator.init(ThisWorkbook.Path, "ち~んw")
で、マクロを書いたブックのあるフォルダに「ち~んw」という名前のフォルダを作成すると同時に、できたFolderオブジェクトを変数「myFolder」に格納している。
あとは、(5)からの6行、
With myFolder Debug.Print .Drive Debug.Print .ParentFolder Debug.Print .Name Debug.Print .Path End With
では、変数「myFolder」に格納されたフォルダ(=新しく作られたフォルダ)について、
- フォルダの存在するドライブ名(Driveプロパティ)
- フォルダの親フォルダ名(ParentFolderプロパティ)
- フォルダ名(Nameプロパティ)
- フォルダのフルパス(Pathプロパティ)
をイミディエイト・ウインドウに表示させる。
実行結果
ほれ、この通り、新しいフォルダが作られ、
フォルダの属性がちゃーんと取得できる。
おわりに
ただ、このクラスが何に便利なのかはよく分からないwww
FileSystemObjectの使いどころについて、もっと勉強しないといけないっぽい。
Addメソッドについて考えた
コレクションのAddメソッドの返り値
Addメソッドの返り値を追加したオブジェクトにするというアイディアを考えたやつは天才
Excelで明細みたいなのを作っていると、それぞれのシートなりブックなりをだいたいはPDF化したり、プリントアウトしたり、という使い方になるんだが、時たま「後で修正する必要があるかも知れんなー」ということで、Excelファイルとして出力したいというときがある。
この間、「一つ一つをExcelファイルにしておきたいなー」と思ってやってみたときにふと気づいたのが標題に書いたAddメソッドの返り値を追加したオブジェクトにするというアイディアを考えたやつは天才ということだった。
シートを新しいブックにコピーして保存するマクロ
仕様は次の通り。
- アクティブシートを新しいブックにコピーする
- 新しくできたブックから、余分なシートを削除する
- コピーしたシートのA1セルの値をファイル名として保存する
とまあ、こんな設定。
リスト1
Public Sub copySheetAndCreateNewExcelFile() Dim Sh As Worksheet Set Sh = ActiveSheet Dim newWb As Workbook Dim str As String str = ThisWorkbook.Path & "\それぞれのExcelファイル\" '……(1)'" str = str & Sh.Range("A1").Value & ".xlsx" Set newWb = Workbooks.Add '……(2)' Sh.Copy before:=newWb.Worksheets(1) '……(3)' Application.DisplayAlerts = False '……(4)' Dim i As Integer With newWb '……(5)' For i = .Worksheets.Count To 2 Step -1 .Worksheets(i).Delete Next End With newWb.SaveAs fileName:=str '……(6)' newWb.Close False '……(7)' Application.DisplayAlerts = True '……(8)' End Sub
(1)からの2行、
str = ThisWorkbook.Path & "\それぞれのExcelファイル\" '" str = str & Sh.Range("A1").Value & ".xlsx"
では、新しくできるブックのファイル名を組み立てて変数strに格納している。
単に、後の記述を簡単にするためだけのこと。
(2)がミソ。
「Addメソッド」という名前からは、
コレクションにオブジェクトを加える
というイメージしか湧いてこない。
だから、私のような凡人がAddメソッドを作っていたとしたら
絶対にvoidメソッドにしてしまう
と思う。
「新しくできたオブジェクトを返り値にしよう」などという発想は出てこないと思うのだ。
Addメソッドの返り値が新規に生成されたオブジェクトである、というたったこれだけのことで(2)のように
Set newWb = Workbooks.Add
たったこれだけの記述で新しいオブジェクトを捕まえることができる。これは本当に素晴らしいアイディアだと思う。
言いたいことは言ったので、これで終わってもいいんだが、せっかくなので残りの部分も説明しておこう。
(3)の
Sh.Copy before:=newWb.Worksheets(1)
では、WorksheetオブジェクトのCopyメソッドを用いてシートを新しくできたブックにコピーしている。
引数「Before」に新しいブックの一番左のシートを指定しているので、コピーしたシートは新しいブックの一番左端に入ることになる。
この後、不要なシートを削除していくので、(4)の
Application.DisplayAlerts = False
で、一旦警告メッセージの表示を止める。
(5)からの5行、
With newWb For i = .Worksheets.Count To 2 Step -1 .Worksheets(i).Delete Next End With
で不要なシートを消す。
Excel2010までと2013以降では、デフォルトのシート数が異なるので、Forループの開始値はこんな書き方になる。
コピーしたシートが先頭に挿入されているので、Forループの開始値は、2010までなら4、2013以降なら2ということになる。
Forループの開始値と終了値をケツからさかのぼるような形にしているのがポイント。こうしないと途中でエラーになる(理由は自分で考えよう)。
まあ、
削除するときはケツから!
というのは基本ですな。
あとは、(6)の
newWb.SaveAs fileName:=str
で名前をつけて保存し、
(7)の
newWb.Close False
で新しくできたブックを閉じたらおしまい。
(8)の
Application.DisplayAlerts = True
で警告メッセージの表示を復活させるのをお忘れなく、といったところか。
おわりに
今まで何の気なしに使っていたメソッドだけれど、やはりプロが作ったものはよく考えられている。
自作クラスのメソッドにも応用できるなあと思った。
ワークシートをPDF化する(ExportAsFixedFormatメソッド)
ExportAsFixedFormatメソッドの三態
ExportAsFixedFormatメソッドの対象オブジェクト
よそにデータを送るときに、PDF化する必要があって、WordであれExcelであれ、よくこのExportAsFixedFormatメソッドにはお世話になっている。
んで、改めて調べてみたら、ExcelVBAの場合、対象オブジェクトが3つ(ホントは4つかな? でもChartオブジェクトとか私は使わないので……)もあると分かった。
すなわち、
の3つ。
まあ、用途というか、実行結果は容易に想像がつく。
上から順に、
- ブック全体をPDF化
- ワークシートをPDF化
- セル範囲をPDF化
ってところだろう。
ExportAsFixedFormatメソッドの使用実験
ワークシートを
こんなふうに用意して、
次のようなコードを書いて実験してみた。
リスト1-1
Private Sub useExportAsFixedFormatMethodOfWorkbook(ByVal filePath As String) ThisWorkbook.ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=filePath & "ワークブック.pdf" '' End Sub
リスト1-2
Private Sub useExportAsFixedFormatMethodOfWorksheet(ByVal filePath As String) Dim Sh As Worksheet Set Sh = ActiveSheet Sh.ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=filePath & "ワークシート.pdf" '' End Sub
リスト1-3
Private Sub useExportAsFixedFormatMethodOfRange(ByVal filePath As String) Dim Sh As Worksheet Set Sh = ActiveSheet Sh.Range("Print_Area").ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=filePath & "印刷範囲.pdf" '' End Sub
以上がオブジェクトごとのコード。どれもそれぞれのオブジェクトに対して単純にExportAsFixedFormatメソッドを実行するだけのコードなので特に説明はいらないと思う。
いづれも、引数filePathで保存先のフォルダパスを受け取るので、あとはそれぞれのプロシージャでファイル名を与えている。
リスト1-3では、オブジェクトに印刷範囲を指定している。
で、この3つのコードを、次のリスト2で実行する。
リスト2
Public Sub testPDFCreation() Dim str As String str = ThisWorkbook.Path & "\超人墓場\" '" Call useExportAsFixedFormatMethodOfWorkbook(str) Call useExportAsFixedFormatMethodOfWorksheet(str) Call useExportAsFixedFormatMethodOfRange(str) End Sub
実行結果
見ての通り、Worksheetオブジェクトに対して実行しても、Range("Print_Area")に対して実行しても結果は同じだった。
ちなみに、Workbookオブジェクトに対して実行すると、バカ正直に全てのワークシートの印刷範囲がPDF化された。
おわりに
……ということは、シートの一部だけをPDFにしたい、という事情でもない限り、ワークシートの印刷範囲をPDF化したいのなら、WorksheetオブジェクトのExportAsFixedFormatメソッドを使った方がラク、ということになりそう。
追記
ExportAsFixedFormat
メソッドを用いたPDF化の場合、ファイルサイズが異様に大きくなってしまう。
そのあたりが気になる方はコチラをどうぞ。
日付をはじめとする数字の表記の問題
日付の1桁の数字のみ全角にして表示する
変な風習
書類なんかの日付の表記(まあ、日付以外もですけど)について、ウチの職場には、
数字が1桁のときは全角、2桁のときは半角!
という謎ルールがあって、これがWordやExcelを使った作業と本当に相性が悪い。
もちろん、この謎ルールのせいで、使用フォントは見出しが「MSゴシック」、本文が「MS明朝」のそれぞれ一択w
Wordなんかの場合、デフォルトだと英数字がCentury(だったかな?)なので、「スタイル」とかの知識のない人たちは皆、
- 書類作成
- 全範囲を選択
- フォントを「MS明朝」(またはMSゴシック)に変更
- 完成
という妙な作業をやっている。
こんなアホなことをせんですむように皆さんに説いて回りたいのはやまやまなれど、
誰でもできる仕事が一人前以上フツーに割り振られている上に、私にしかできない仕事が発生したら純粋に上積みで私に回ってくる
という事情、及び
皆「忙しい」が口癖みたいになっているので、教えようとしても迷惑がられる
というのが現状なので、黙っているwww
まあ、そんな職場です。
Excelで変な風習に合わせる
せっかくExcelには
データは日付型として持っておいて表示形式だけを操作する
という超便利な機能があるのに、この変な風習のせいでExcelに日付型データを入力するという発想自体が根こそぎ刈り取られているのが実情。
しかし、この状態を放置するのはあまりにむかつくので、
日付データを「1けた全角、ほか半角」方式に変換する関数
を作った。
日付データを「1けた全角、ほか半角」方式に変換する関数
リスト1
Private Function adjustExpressionOfDate(ByVal style As Integer, _ ByVal dt As Date) As String '……(1)' Dim str As String '……(2)' Dim m As String Dim d As String m = Month(dt) '……(3)' d = Day(dt) '第1引数が「WHEN_SINGLE_DIGIT~」だったら1桁の数字を全角にする' If style = WHEN_SINGLE_DIGIT_EXCHANGE_TO_WIDE Then If m < 10 Then m = StrConv(m, vbWide) '……(4)' If d < 10 Then d = StrConv(d, vbWide) '文字列として結合する' str = m & "月" & d & "日" & "(" & Format(dt, "aaa") & ")" '……(5)' adjustExpressionOfDate = str '……(6)' Exit Function '……(7)' End If '第1引数が「WHEN_SINGLE_DIGIT~」でなかったら半角のまま文字列にして返す' adjustExpressionOfDate = m & "月" & d & "日" & "(" & Format(dt, "aaa") & ")" '……(8)' End Function
(1)で、
Private Function adjustExpressionOfDate(ByVal style As Integer, _ ByVal dt As Date) As String
2つの引数を渡すようにしている。
第1引数の「style」で変換方式を指定するようにし、
第2引数のdtで日付データを渡すようにした。
「style」については、今回はとりあえず「○月○日(曜日)」という形式を定数「WHEN_SINGLE_DIGIT_EXCHANGE_TO_WIDE」(中身はIntegerの「1」。長っw)で指定するようにした。
で、どの道「8月29日(火)」みたいな形にしてしまうともはや日付データとしては扱えないので、返り値はString型にした。
(2)からの3行
Dim str As String Dim m As String Dim d As String
で変数を宣言。それぞれの役割は以下の通り。
- 「str」には最終的にできあがった日付文字列を格納する
※不要ですが、可読性向上のために使う。 - 「m」には月の数字を格納する
- 「d」には日の数字を格納する
(3)からの2行
m = Month(dt) d = Day(dt)
で変数「m」、「d」にそれぞれ月・日の数値を代入。
この関数に渡された第1引数が「WHEN_SINGLE_DIGIT_EXCHANGE_TO_WIDE」だったら、(4)以下の処理に移る。
(4)からの2行
If m < 10 Then m = StrConv(m, vbWide) If d < 10 Then d = StrConv(d, vbWide)
で、それぞれ1桁だったら全角に変換する。
あとは、(5)の
str = m & "月" & d & "日" & "(" & Format(dt, "aaa") & ")"
で「○月○日(曜日)」の形式になるように整形して変数「str」に代入。
(6)の
adjustExpressionOfDate = str
で返り値を設定し、(7)の
Exit Function
で呼び出し元に帰る。
ここでExitするのは、後々の拡張性のため。
今回は「○月○日(曜日)」の形式だったが、今後
「元号も入れんかい!」
とか後出しジャンケンされたときには、その処理を書いて、第1引数の「style」で分岐できるようにすればよい。
(8)の
adjustExpressionOfDate = m & "月" & d & "日" & "(" & Format(dt, "aaa") & ")"
を最後に書いているのはそういうこと。
実行結果
この状態で、次のコードを書いて実行。
リスト2
Public Sub getAdjustedDateString() ActiveCell.Offset(0, 1).Value = _ adjustExpressionOfDate(WHEN_SINGLE_DIGIT_EXCHANGE_TO_WIDE, _ ActiveCell.Value) End Sub
無事に変換された。
ちなみに、月、日ともに1桁でも
この通り大丈夫。
文字の位置がそろっていないのはプロポーショナルフォントにしているせい。
みんな大好き(笑)「MSゴシック」にすると……。
ほれ、このとおりピッタリそろった! よかったねw
おわりに
しっかし、こんなしょうもないことに神経を使うなんて、それこそ無駄だと思うんですけど。
こんな謎風習を生きながらえさせている上長には「働き方改革」とかほざいてほしくないっす。
構造体の要素を並べ替える
構造体配列の要素をパラメータの値に従ってソートする
なんかこう、仕事が泥沼で、長らく更新できませんでした。今も泥沼の最中なんですが、現実逃避して書いています。
さて、仕事で希望調査みたいなのをやった。まあ、データ集約するだけなら楽勝だったんだけれど、問題発生。
希望(日付入り)を3つ挙げる、という項目があったんだが、「第1希望~第3希望」みたいな書き方になっていたため、3つが日付順に並んでいない回答が結構あったということ。
集約したときに人によって並び順が違う、というのはあまりにブサイク。しかも後から「おい、これ日付順に並び方を統一しとかんかい」とか言われたら死ぬので、今のうちに対応しておかないと……と考えた。
イメージはこんな感じ。
たとえば、「中野 浩一」さんの場合だと、
久留米(8/1)→小倉(7/29)→佐世保(7/28)
と並んでいるやつを、
佐世保(7/28)→小倉(7/29)→久留米(8/1)
という順に列ごと並べ替えたいわけなんである。
作戦
で、次のような作戦を考えた。
こんな感じ。
構造体の作成
標準モジュールの宣言セクションで以下のように設定。
リスト1
Option Explicit Public Type wishData personName As String wishPlace1 As String wishDate1 As Date wishPlace2 As String wishDate2 As Date wishPlace3 As String wishDate3 As Date End Type
構造体配列に各人のデータをセット
リスト2
Dim Sh As Worksheet Set Sh = ActiveSheet Dim wsData(4) As wishData '……(1)' Dim i As Integer 'データを配列にセット' For i = 0 To 4 '……(2)' With wsData(i) .personName = Sh.Range("S" & i + 3).Value .wishPlace1 = Sh.Range("T" & i + 3).Value .wishDate1 = Sh.Range("U" & i + 3).Value .wishPlace2 = Sh.Range("V" & i + 3).Value .wishDate2 = Sh.Range("W" & i + 3).Value .wishPlace3 = Sh.Range("X" & i + 3).Value .wishDate3 = Sh.Range("Y" & i + 3).Value End With Next
かなり原始的な書き方になっているのはご容赦ください。
(1)の
Dim wsData(4) As wishData
でとりあえず5人分の配列変数を準備して、
(2)からの11行
For i = 0 To 4 '……(2)' With wsData(i) .personName = Sh.Range("S" & i + 3).Value .wishPlace1 = Sh.Range("T" & i + 3).Value .wishDate1 = Sh.Range("U" & i + 3).Value .wishPlace2 = Sh.Range("V" & i + 3).Value .wishDate2 = Sh.Range("W" & i + 3).Value .wishPlace3 = Sh.Range("X" & i + 3).Value .wishDate3 = Sh.Range("Y" & i + 3).Value End With Next
で5人分のデータを配列に格納しているだけ。
構造体内の要素を並べ替える
「wishDate1」~「wishDate3」の大小によって、構造体内の要素を入れ替える処理が必要。
メンドクサイのは、場所データ(wishPlace○)と日付データ(wishData○)をセットで入れ替えないといけない点。
アホみたいなやり方だと笑われそうだけど、次のような専用プロシージャを作った。
基本的なやり方は、入れ替え前の構造体をobjDataとすると、
- objDataの2番目の日付と3番目の日付を比較する
- 2番目の日付の方が大きかったら、一旦tmpDataにobjDataを丸ごとコピーする
- objDataの2番目の場所・日付データのところに3番目の場所・日付を上書きする
- objDataの2番目の場所・日付データのところにtmpDataの3番目の場所・日付を上書きする
※これで3番目と2番目が入れ替わる。 - objDataの1番目の日付と2番目の日付を比較する
- 1番目の日付の方が大きかったら、同様にobjDataの1番目と2番目を入れ替える
※この段階で一番小さな日付・場所が1番目に来ている。 - objDataの3番目の日付と2番目の日付を比較する
- 2番目の日付の方が大きかったら、同様にobjDataの2番目と3番目を入れ替える
- 並べ替え完了
バブルソートってやつですね。
リスト3
Private Sub sortDataByDate(ByRef objData As wishData) Dim tmpData As wishData With objData 'バブルソート1回目' If .wishDate2 > .wishDate3 Then tmpData = objData '……(1)' .wishPlace3 = .wishPlace2 '……(2)' .wishDate3 = .wishDate2 '……(3)' .wishPlace2 = tmpData.wishPlace3 '……(4)' .wishDate2 = tmpData.wishDate3 '……(5)' End If 'バブルソート2回目' If .wishDate1 > .wishDate2 Then tmpData = objData .wishPlace2 = .wishPlace1 .wishDate2 = .wishDate1 .wishPlace1 = tmpData.wishPlace2 .wishDate1 = tmpData.wishDate2 End If 'バブルソート3回目' If .wishDate2 > .wishDate3 Then tmpData = objData .wishPlace3 = .wishPlace2 .wishDate3 = .wishDate2 .wishPlace2 = tmpData.wishPlace3 .wishDate2 = tmpData.wishDate3 End If End With End Sub
うーむ、我ながら吐き気を催すようなぶさいくなコードwww
いちおう、データ入れ替えのところだけ説明します。
「バブルソート1回目」の部分、
'バブルソート1回目' If .wishDate2 > .wishDate3 Then tmpData = objData '……(1)' .wishPlace3 = .wishPlace2 '……(2)' .wishDate3 = .wishDate2 '……(3)' .wishPlace2 = tmpData.wishPlace3 '……(4)' .wishDate2 = tmpData.wishDate3 '……(5)' End If
まず、2番目の日付と3番目の日付を比較して、2番目の方が大きかったら(1)以下で2番目の要素と3番目の要素を入れ替える。
(1)で元のデータをtmpDataに格納しておいて、
(2)、(3)で2番目だったデータを3番目のところに上書きし、
(4)、(5)でtmpDataに避難しておいたデータを用いて2番目のところに元々3番目だったデータを上書きする
という段取り。
構造体変数を引数にするときには、参照渡ししかできないみたいなので、Functionにする必要がなかった。
このプロシージャを呼び出して並べ替える。そのためのコードがコチラ。
リスト4
For i = 0 To 4 Call sortDataByDate(wsData(i)) Next
これだけです。Forループで i 番目のwsDataを渡しています。
シートに書き出す
今回は、別の場所に転記先の表を作った。
リスト5
For i = 0 To 4 With wsData(i) Sh.Range("AA" & i + 3).Value = .personName Sh.Range("AB" & i + 3).Value = .wishPlace1 Sh.Range("AC" & i + 3).Value = .wishDate1 Sh.Range("AD" & i + 3).Value = .wishPlace2 Sh.Range("AE" & i + 3).Value = .wishDate2 Sh.Range("AF" & i + 3).Value = .wishPlace3 Sh.Range("AG" & i + 3).Value = .wishDate3 End With Next
何の工夫もない書き方ですんません。
コード全体
いちおう全体を挙げておきます。
リスト全体
Option Explicit '構造体の宣言' Public Type wishData personName As String wishPlace1 As String wishDate1 As Date wishPlace2 As String wishDate2 As Date wishPlace3 As String wishDate3 As Date End Type Public Sub exchangeWishList() Dim Sh As Worksheet Set Sh = ActiveSheet Dim wsData(4) As wishData Dim i As Integer 'データを配列にセット' For i = 0 To 4 With wsData(i) .personName = Sh.Range("S" & i + 3).Value .wishPlace1 = Sh.Range("T" & i + 3).Value .wishDate1 = Sh.Range("U" & i + 3).Value .wishPlace2 = Sh.Range("V" & i + 3).Value .wishDate2 = Sh.Range("W" & i + 3).Value .wishPlace3 = Sh.Range("X" & i + 3).Value .wishDate3 = Sh.Range("Y" & i + 3).Value End With Next '構造体配列の要素並べ替え' For i = 0 To 4 Call sortDataByDate(wsData(i)) Next 'シートに書き出す' For i = 0 To 4 With wsData(i) Sh.Range("AA" & i + 3).Value = .personName Sh.Range("AB" & i + 3).Value = .wishPlace1 Sh.Range("AC" & i + 3).Value = .wishDate1 Sh.Range("AD" & i + 3).Value = .wishPlace2 Sh.Range("AE" & i + 3).Value = .wishDate2 Sh.Range("AF" & i + 3).Value = .wishPlace3 Sh.Range("AG" & i + 3).Value = .wishDate3 End With Next End Sub '並べ替え用プロシージャ' Private Sub sortDataByDate(ByRef objData As wishData) Dim tmpData As wishData With objData 'バブルソート1回目' If .wishDate2 > .wishDate3 Then tmpData = objData .wishPlace3 = .wishPlace2 .wishDate3 = .wishDate2 .wishPlace2 = tmpData.wishPlace3 .wishDate2 = tmpData.wishDate3 End If 'バブルソート2回目' If .wishDate1 > .wishDate2 Then tmpData = objData .wishPlace2 = .wishPlace1 .wishDate2 = .wishDate1 .wishPlace1 = tmpData.wishPlace2 .wishDate1 = tmpData.wishDate2 End If 'バブルソート3回目' If .wishDate2 > .wishDate3 Then tmpData = objData .wishPlace3 = .wishPlace2 .wishDate3 = .wishDate2 .wishPlace2 = tmpData.wishPlace3 .wishDate2 = tmpData.wishDate3 End If End With
End Sub
実行結果
実行前
実行後
ちゃんと日付順に整理された。
おわりに
うーん……。このままだとまるで応用が利かないなあ。
漢字テストメーカーを作ってみた
漢字テストメーカーを作ってみた
プロシージャの構成
- 問題データ抽出用プロシージャ
Private Sub extractQuestions - 乱数発生・ナンバリング用プロシージャ
Private Sub setRandomNumber - 抽出問題並べ替えプロシージャ
Private Sub sortExtractedQuestions - テスト様式への転記プロシージャ
Private Sub setQuestions - 下線部フォント変更プロシージャ
Private Sub changeFontIfUnderLine
ざっとこんな感じ。
ソースコード
リスト1
Private Sub extractQuestions() '問題データを抽出する' Dim dtExtractor As DataExtractor '……(1)' Set dtExtractor = New DataExtractor With ThisWorkbook Set orgSh = .Worksheets("問題データ") Set extractSh = .Worksheets("抽出") End With dtExtractor.extractData orgSh.Range("A1").CurrentRegion, _ Range("CriteriaRange"), _ Range("RangeCopyTo") '……(2)' Set dtExtractor = Nothing End Sub
(1)のDataExtractorクラスについては、
を参照。
(2)では、そのDataExtractorクラスのextractDataメソッドを使って試験範囲の分の問題だけを「抽出」シートに抽出している。
元データの範囲、条件指定セルの範囲、抽出先ラベル、の3つのRangeオブジェクトを指定するだけで抽出ができるので、これは案外便利かも知れんw
リスト2
Private Sub setRandomNumber() '乱数を発生させて抽出後の問題番号セルにセットする' With ThisWorkbook Set extractSh = .Worksheets("抽出") End With Dim cnt As Integer cnt = extractSh.Cells(Rows.Count, 1).End(xlUp).Row - 1 Dim qNumbers() As Integer ReDim qNumbers(1 To cnt) Dim i As Integer Dim n As Integer Dim hasDone As Boolean Randomize For i = 1 To cnt Do qNumbers(i) = Int(Rnd * cnt) + 1 hasDone = True If i > 1 Then For n = 1 To i - 1 If qNumbers(i) = qNumbers(n) Then hasDone = False Exit For End If Next End If Loop While hasDone = False Next '乱数をセルに書き込む' For i = 1 To cnt extractSh.Range("B" & i + 1).Value = qNumbers(i) Next '乱数ナンバリングによって並べ替える' Call sortExtractedQuestions End Sub
こちらのプロシージャについては、
を参照。
リスト3
Private Sub sortExtractedQuestions() '抽出シートを並べ替える' Set extractSh = ThisWorkbook.Worksheets("抽出") With extractSh .Range("A1").CurrentRegion.Sort _ Key1:=.Range("B2"), _ Header:=xlYes, _ Order1:=xlAscending End With End Sub
こちらも、単におなじみ、RangeオブジェクトのSortメソッドを使っているだけなので、説明不要と思う。
リスト4
Private Sub setQuestions() 'テスト問題の様式に問題データをセットする' With ThisWorkbook Set orgSh = .Worksheets("問題データ") Set extractSh = .Worksheets("抽出") End With Dim i As Integer Dim objCell As Range For i = 1 To Range("NumberOfQuestions").Value Set objCell = extractSh.Range("C" & i + 1) '下線部のフォントを変える' Call changeFontIfUnderLine(objCell, "MS Pゴシック") '問題データを問題様式に貼り付ける' objCell.Copy With Range("Question" & Format(i, "0#")) '……(1)' .PasteSpecial xlPasteValues '……(2)' .PasteSpecial xlPasteFormats '……(3)' .Orientation = xlVertical '……(4)' .VerticalAlignment = xlTop '……(5)' .HorizontalAlignment = xlCenter '……(6)' .WrapText = True '……(7)' End With Next Range("NumberOfTimes").Value = Range("CriteriaRange").Cells(2, 1).Value '……(8)' Range("TestBody").Copy Range("CopyStartCell") '……(9)' Application.CutCopyMode = False End Sub
並べ替え終わった問題データをテスト問題の様式に貼り付けていくだけなんだが、横書きのデータを縦書きにして、なおかつ文字の書式はそのまま、ということなので、それなりにメンドウだった。
(1)からの8行
With Range("Question" & Format(i, "0#")) '……(1)' .PasteSpecial xlPasteValues '……(2)' .PasteSpecial xlPasteFormats '……(3)' .Orientation = xlVertical '……(4)' .VerticalAlignment = xlTop '……(5)' .HorizontalAlignment = xlCenter '……(6)' .WrapText = True '……(7)' End With
クリップボードにコピーされた問題データを貼り付けるだけなのだが、こんなにメンドウなことになっている。
縦書きにすると、右から左、という不自然な順序で貼り付けないといけないので、あらかじめ問題転記先のセルに右から左に「Question01」~「Question05」という風に名前を定義している。
こうしておくことで、(1)の
Range("Question" & Format(i, "0#"))
のようにForループと相性の良い形で問題の転記先を指定することができる。
(2)~(7)は貼り付け方の指定。
一応、列挙しておくと、
- (2):値のみ貼り付け
- (3):書式貼り付け
下線とかフォントの情報を貼り付けるためには致し方ない? - (4):縦書きにする
- (5):縦位置は上揃え
- (6):横位置中央揃え
- (7):テキストの折り返し
フォント情報や下線情報を保持したまま貼り付けるために書式ごと貼り付けると、問題様式側の書式が死ぬので、貼り付けた直後に設定し直す、といった流れになっている。もっとうまいやり方がありそうだけど。
リスト5
Private Sub changeFontIfUnderLine(ByVal objCell As Range, _ ByVal fontName As String) '下線が施された文字のフォントを変える' Dim i As Integer Dim hasStarted As Boolean Dim tmpStart As Integer Dim tmpEnd As Integer For i = 1 To Len(objCell.Value) With objCell.Characters(i, 1) '初めてアンダーラインにぶつかったときのiを記録する' If hasStarted = False And _ .Font.Underline <> xlUnderlineStyleNone Then tmpStart = i hasStarted = True End If 'hasStartedがTrueの状態でアンダーラインのない文字にぶつかったら' '下線部が終わったということなのでiを記録してループを抜ける。' If hasStarted = True And _ .Font.Underline = xlUnderlineStyleNone Then tmpEnd = i Exit For End If End With Next DoEvents 'この時点でtmpEnd - tmpStartの値がアンダーライン文字列の字数' 'アンダーラインの部分のフォントを変える' objCell.Characters(tmpStart, tmpEnd - tmpStart).Font.Name = fontName hasStarted = False End Sub
こちらについては、
をどうぞ。
実行結果
「問題データ」シートに、
こんなふうに問題データを準備。
「抽出」シートは、
こんな具合に抽出用の項目ラベルと条件指定用セルを準備。
んで、下記のコードで実行した。
Option Explicit Dim orgSh As Worksheet Dim extractSh As Worksheet Public Sub main() Call extractQuestions Call setRandomNumber Call setQuestions End Sub
おお、うまいことできとる!
Excelの画面上ではガタガタだけれど、PDFにしてみると、
まあまあいい感じではないでしょうか。
おわりに
もっとサクッとできると思っていたけど、縦書きにしないといけないこともあって、案外手間取ってしまった。
しかし、けっこう使い慣れてきたと思っていたExcelVBAにも未知のオブジェクトがたくさんあってちょっとびびってしまった。達人への道のりは長いなあ……。
セル内のアンダーライン部分のみフォントを変える
文字列のうち、アンダーライン部分のフォントだけを変える
ツイッターのフォロワーさんの「漢字テストの問題をランダムに作成できんかなー」みたいなツイートに反応して、どうやったらできるのか考えてみた。
傍線部分だけゴシックにしないといけない
文字列に下線(傍線)を引くのは自動化できないにしても、下線部だけを狙い撃ちでフォントを変えるというのは、手作業でやると死ぬほどめんどくさい。
しかし、普段文字単位で書式をいじくることなんて皆無だから、どうしていいのか分からなかった。んで、調べてみると、Charactersオブジェクトを取得して書式を施せばよいと分かった。
Characters オブジェクトを使用すると、文字列のうちの一部だけを対象にした修正ができます。
Characters オブジェクトを取得するには、Characters(start, length) プロパティを使用します。引数 start には開始する文字の先頭位置の番号を指定します。引数 length には、文字数を指定します。
ということなので、なんとかなりそう。
考え方
次のような考え方でコードを書くことにした。
- 1文字目から順番にチェックする
- 初めてアンダーラインのある文字にぶつかったときにフラグを立て、何文字目かを変数tmpStartに記録する
- アンダーラインのない文字にぶつかったら、何文字目かを変数tmpEndに記録してループを抜ける
- Charactersオブジェクトの引数startにtmpStartを、引数lengthにtmpEnd - tmpStartを渡すと、アンダーライン部分のCharactersオブジェクトが取得できる
- 後は、4.で得られたCharactersオブジェクトのFontプロパティをあれこれいじくる
と、こんな感じ。
実装
リスト1
Private Sub changeFontIfUnderLine(ByVal objCell As Range, _ ByVal fontName As String) '下線が施された文字のフォントを変える' Dim i As Integer Dim hasStarted As Boolean Dim tmpStart As Integer Dim tmpEnd As Integer For i = 1 To Len(objCell.Value) With objCell.Characters(i, 1) '初めてアンダーラインにぶつかったときのiを記録する' If hasStarted = False And _ .Font.Underline <> xlUnderlineStyleNone Then tmpStart = i hasStarted = True End If 'hasStartedがTrueの状態でアンダーラインのない文字にぶつかったら' '下線部が終わったということなのでiを記録してループを抜ける。' If hasStarted = True And _ .Font.Underline = xlUnderlineStyleNone Then tmpEnd = i Exit For End If End With Next 'この時点でtmpEnd - tmpStartの値がアンダーライン文字列の字数' 'アンダーラインの部分のフォントを変える' objCell.Characters(tmpStart, tmpEnd - tmpStart).Font.Name = fontName End Sub
コード中のコメントでだいたい何をやっているのかは分かると思う。
全体の処理の途中で呼び出すメソッドのようなものなので、Privateにして呼び出され専用にしてある。引数で渡している処理対象セルやフォント名を決め打ちにしてやれば、単独のプロシージャとしても使えると思う。
実行結果
明朝体の「ケイオウカク」のところだけが、
無事にゴシック体になった。
おわりに
Charactersオブジェクトをうまく使えば、Excelのセル内の文字列に関するしちめんどくさい作業のかなりの部分を軽減できるようになるかも知れない。
いづれは、クラスを作って手軽に扱えるようにしてみたい。