フォルダを作成するクラス

フォルダ作成クラス

任意のディレクトリに任意の名前のフォルダを作る

新規フォルダを作るときは、MkDir関数を使う。

まあ、それはそれでいいのだが、何かこう、作りっぱなし感があって気持ち悪い。

せっかくなので、FileSystemObjectの練習も兼ねて、

フォルダを作るついでにFolderオブジェクトを返り値とするようなメソッドを持たせるクラスを作ってみよう

と思い立った。

相変わらず、何の役に立つのかは分からんがｗ

フォルダを作るクラス

例によってクラスモジュールを挿入し、オブジェクト名を「FolderCreator」とした。

あ、参照設定で「Microsoft Scripting Runtime」にチェックを入れていますよ。

リスト１　クラスモジュールのコード

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)からの３行

Private folderPath_ As String
Private fsObject_ As FileSystemObject
Private createdFolder_ As Folder

で３つの変数を準備。

「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メソッドを呼ぶ

ということを決めて、擬似的なコンストラクタとして使う。

第１引数に新しくフォルダを作りたいディレクトリのフルパス、第２引数に新しいフォルダの名前を指定する。

ここからはinitメソッドの中身。

まず、(4)の

folderPath_ = rootPath & "\" & folderName

で新しく作りたいフォルダのフルパス文字列を合成する。

(5)からの３行、

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クラスの使用

下記のコードで使ってみる。

リスト２　標準モジュールのコード

Public Sub test01()
  Dim myFolderCreator As FolderCreator    '……(1)'
  Set myFolderCreator = New FolderCreator    '……(2)'
  Dim myFolder As Folder    '……(3)'
  Set myFolder = myFolderCreator.init(ThisWorkbook.Path, "ち～んｗ")    '……(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, "ち～んｗ")

で、マクロを書いたブックのあるフォルダに「ち～んｗ」という名前のフォルダを作成すると同時に、できたFolderオブジェクトを変数「myFolder」に格納している。

あとは、(5)からの６行、

With myFolder
  Debug.Print .Drive
  Debug.Print .ParentFolder
  Debug.Print .Name
  Debug.Print .Path
End With

では、変数「myFolder」に格納されたフォルダ（＝新しく作られたフォルダ）について、

• フォルダの存在するドライブ名（Driveプロパティ）
• フォルダの親フォルダ名（ParentFolderプロパティ）
• フォルダ名（Nameプロパティ）
• フォルダのフルパス（Pathプロパティ）

をイミディエイト・ウインドウに表示させる。

実行結果

ほれ、この通り、新しいフォルダが作られ、

フォルダの属性がちゃーんと取得できる。

おわりに

ただ、このクラスが何に便利なのかはよく分からないｗｗｗ

FileSystemObjectの使いどころについて、もっと勉強しないといけないっぽい。

@akashi_keirin on Twitter

Addメソッドについて考えた

コレクションのAddメソッドの返り値

Addメソッドの返り値を追加したオブジェクトにするというアイディアを考えたやつは天才

Excelで明細みたいなのを作っていると、それぞれのシートなりブックなりをだいたいはPDF化したり、プリントアウトしたり、という使い方になるんだが、時たま「後で修正する必要があるかも知れんなー」ということで、Excelファイルとして出力したいというときがある。

この間、「一つ一つをExcelファイルにしておきたいなー」と思ってやってみたときにふと気づいたのが標題に書いたAddメソッドの返り値を追加したオブジェクトにするというアイディアを考えたやつは天才ということだった。

シートを新しいブックにコピーして保存するマクロ

仕様は次の通り。

1. アクティブシートを新しいブックにコピーする
2. 新しくできたブックから、余分なシートを削除する
3. コピーしたシートのＡ１セルの値をファイル名として保存する

とまあ、こんな設定。

リスト１

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)からの２行、

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)からの５行、

With newWb
  For i = .Worksheets.Count To 2 Step -1
    .Worksheets(i).Delete
  Next
End With

で不要なシートを消す。

Excel2010までと2013以降では、デフォルトのシート数が異なるので、Forループの開始値はこんな書き方になる。

コピーしたシートが先頭に挿入されているので、Forループの開始値は、2010までなら４、2013以降なら２ということになる。

Forループの開始値と終了値をケツからさかのぼるような形にしているのがポイント。こうしないと途中でエラーになる（理由は自分で考えよう）。

まあ、

削除するときはケツから！

というのは基本ですな。

あとは、(6)の

newWb.SaveAs fileName:=str

で名前をつけて保存し、

(7)の

newWb.Close False

で新しくできたブックを閉じたらおしまい。

(8)の

Application.DisplayAlerts = True

で警告メッセージの表示を復活させるのをお忘れなく、といったところか。

おわりに

今まで何の気なしに使っていたメソッドだけれど、やはりプロが作ったものはよく考えられている。

自作クラスのメソッドにも応用できるなあと思った。

@akashi_keirin on Twitter

ワークシートをPDF化する（ExportAsFixedFormatメソッド）

ExportAsFixedFormatメソッドの三態

ExportAsFixedFormatメソッドの対象オブジェクト

よそにデータを送るときに、PDF化する必要があって、WordであれExcelであれ、よくこのExportAsFixedFormatメソッドにはお世話になっている。

んで、改めて調べてみたら、ExcelVBAの場合、対象オブジェクトが３つ（ホントは４つかな？　でもChartオブジェクトとか私は使わないので……）もあると分かった。

すなわち、

• Workbook.ExportAsFixedFormatメソッド
• Worksheet.ExportAsFixedFormatメソッド
• Range.ExportAsFixedFormatメソッド

の３つ。

まあ、用途というか、実行結果は容易に想像がつく。

上から順に、

• ブック全体を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では、オブジェクトに印刷範囲を指定している。

で、この３つのコードを、次のリスト２で実行する。

リスト２

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化の場合、ファイルサイズが異様に大きくなってしまう。

そのあたりが気になる方はコチラをどうぞ。

akashi-keirin.hatenablog.com

akashi-keirin.hatenablog.com

日付をはじめとする数字の表記の問題

日付の１桁の数字のみ全角にして表示する

変な風習

書類なんかの日付の表記（まあ、日付以外もですけど）について、ウチの職場には、

数字が１桁のときは全角、２桁のときは半角！

という謎ルールがあって、これがWordやExcelを使った作業と本当に相性が悪い。

もちろん、この謎ルールのせいで、使用フォントは見出しが「ＭＳゴシック」、本文が「ＭＳ明朝」のそれぞれ一択ｗ

Wordなんかの場合、デフォルトだと英数字がCentury（だったかな？）なので、「スタイル」とかの知識のない人たちは皆、

• 書類作成
• 全範囲を選択
• フォントを「ＭＳ明朝」（またはＭＳゴシック）に変更
• 完成

という妙な作業をやっている。

こんなアホなことをせんですむように皆さんに説いて回りたいのはやまやまなれど、

誰でもできる仕事が一人前以上フツーに割り振られている上に、私にしかできない仕事が発生したら純粋に上積みで私に回ってくる

という事情、及び

皆「忙しい」が口癖みたいになっているので、教えようとしても迷惑がられる

というのが現状なので、黙っているｗｗｗ

まあ、そんな職場です。

Excelで変な風習に合わせる

せっかくExcelには

データは日付型として持っておいて表示形式だけを操作する

という超便利な機能があるのに、この変な風習のせいでExcelに日付型データを入力するという発想自体が根こそぎ刈り取られているのが実情。

しかし、この状態を放置するのはあまりにむかつくので、

日付データを「１けた全角、ほか半角」方式に変換する関数

を作った。

日付データを「１けた全角、ほか半角」方式に変換する関数

リスト１

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)
  '第１引数が「WHEN_SINGLE_DIGIT～」だったら１桁の数字を全角にする'
  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
  '第１引数が「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

２つの引数を渡すようにしている。

第１引数の「style」で変換方式を指定するようにし、
第２引数のdtで日付データを渡すようにした。

「style」については、今回はとりあえず「○月○日（曜日）」という形式を定数「WHEN_SINGLE_DIGIT_EXCHANGE_TO_WIDE」（中身はIntegerの「1」。長っｗ）で指定するようにした。

で、どの道「８月29日（火）」みたいな形にしてしまうともはや日付データとしては扱えないので、返り値はString型にした。

(2)からの３行

Dim str As String
Dim m As String
Dim d As String

で変数を宣言。それぞれの役割は以下の通り。

• 「str」には最終的にできあがった日付文字列を格納する
  ※不要ですが、可読性向上のために使う。
• 「m」には月の数字を格納する
• 「d」には日の数字を格納する

(3)からの２行

m = Month(dt)
d = Day(dt)

で変数「m」、「d」にそれぞれ月・日の数値を代入。

この関数に渡された第１引数が「WHEN_SINGLE_DIGIT_EXCHANGE_TO_WIDE」だったら、(4)以下の処理に移る。

(4)からの２行

If m < 10 Then m = StrConv(m, vbWide)
If d < 10 Then d = StrConv(d, vbWide)

で、それぞれ１桁だったら全角に変換する。

あとは、(5)の

str = m & "月" & d & "日" & "（" & Format(dt, "aaa") & "）"

で「○月○日（曜日）」の形式になるように整形して変数「str」に代入。

(6)の

adjustExpressionOfDate = str

で返り値を設定し、(7)の

Exit Function

で呼び出し元に帰る。

ここでExitするのは、後々の拡張性のため。

今回は「○月○日（曜日）」の形式だったが、今後

「元号も入れんかい！」

とか後出しジャンケンされたときには、その処理を書いて、第１引数の「style」で分岐できるようにすればよい。

(8)の

adjustExpressionOfDate = m & "月" & d & "日" & "（" & Format(dt, "aaa") & "）"

を最後に書いているのはそういうこと。

実行結果

この状態で、次のコードを書いて実行。

リスト２

Public Sub getAdjustedDateString()
  ActiveCell.Offset(0, 1).Value = _
    adjustExpressionOfDate(WHEN_SINGLE_DIGIT_EXCHANGE_TO_WIDE, _
                           ActiveCell.Value)
End Sub

無事に変換された。

ちなみに、月、日ともに１桁でも

この通り大丈夫。

文字の位置がそろっていないのはプロポーショナルフォントにしているせい。

みんな大好き（笑）「ＭＳゴシック」にすると……。

ほれ、このとおりピッタリそろった！　よかったねｗ

おわりに

しっかし、こんなしょうもないことに神経を使うなんて、それこそ無駄だと思うんですけど。

こんな謎風習を生きながらえさせている上長には「働き方改革」とかほざいてほしくないっす。

@akashi_keirin on Twitter

構造体の要素を並べ替える

構造体配列の要素をパラメータの値に従ってソートする

なんかこう、仕事が泥沼で、長らく更新できませんでした。今も泥沼の最中なんですが、現実逃避して書いています。

さて、仕事で希望調査みたいなのをやった。まあ、データ集約するだけなら楽勝だったんだけれど、問題発生。

希望（日付入り）を３つ挙げる、という項目があったんだが、「第１希望～第３希望」みたいな書き方になっていたため、３つが日付順に並んでいない回答が結構あったということ。

集約したときに人によって並び順が違う、というのはあまりにブサイク。しかも後から「おい、これ日付順に並び方を統一しとかんかい」とか言われたら死ぬので、今のうちに対応しておかないと……と考えた。

イメージはこんな感じ。

たとえば、「中野　浩一」さんの場合だと、

久留米（8/1）→小倉（7/29）→佐世保（7/28）

と並んでいるやつを、

佐世保（7/28）→小倉（7/29）→久留米（8/1）

という順に列ごと並べ替えたいわけなんである。

作戦

で、次のような作戦を考えた。

1. 各人のデータを構造体変数にまとめて、配列に格納する
2. 各構造体の日付パラメータをもとに、バブルソートアルゴリズムを用いて並べ変える
3. 表に書き出す

こんな感じ。

構造体の作成

標準モジュールの宣言セクションで以下のように設定。

リスト１

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

構造体配列に各人のデータをセット

リスト２

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

でとりあえず５人分の配列変数を準備して、

(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

で５人分のデータを配列に格納しているだけ。

構造体内の要素を並べ替える

「wishDate1」～「wishDate3」の大小によって、構造体内の要素を入れ替える処理が必要。

メンドクサイのは、場所データ（wishPlace○）と日付データ（wishData○）をセットで入れ替えないといけない点。

アホみたいなやり方だと笑われそうだけど、次のような専用プロシージャを作った。

基本的なやり方は、入れ替え前の構造体をobjDataとすると、

1. objDataの２番目の日付と３番目の日付を比較する
2. ２番目の日付の方が大きかったら、一旦tmpDataにobjDataを丸ごとコピーする
3. objDataの２番目の場所・日付データのところに３番目の場所・日付を上書きする
4. objDataの２番目の場所・日付データのところにtmpDataの３番目の場所・日付を上書きする
   ※これで３番目と２番目が入れ替わる。
5. objDataの１番目の日付と２番目の日付を比較する
6. １番目の日付の方が大きかったら、同様にobjDataの１番目と２番目を入れ替える
   ※この段階で一番小さな日付・場所が１番目に来ている。
7. objDataの３番目の日付と２番目の日付を比較する
8. ２番目の日付の方が大きかったら、同様にobjDataの２番目と３番目を入れ替える
9. 並べ替え完了

バブルソートってやつですね。

リスト３

Private Sub sortDataByDate(ByRef objData As wishData)
  Dim tmpData As wishData
  With objData
    'バブルソート１回目'
    If .wishDate2 > .wishDate3 Then
      tmpData = objData    '……(1)'
      .wishPlace3 = .wishPlace2    '……(2)'
      .wishDate3 = .wishDate2    '……(3)'
      .wishPlace2 = tmpData.wishPlace3    '……(4)'
      .wishDate2 = tmpData.wishDate3    '……(5)'
    End If
    'バブルソート２回目'
    If .wishDate1 > .wishDate2 Then
      tmpData = objData
      .wishPlace2 = .wishPlace1
      .wishDate2 = .wishDate1
      .wishPlace1 = tmpData.wishPlace2
      .wishDate1 = tmpData.wishDate2
    End If
    'バブルソート３回目'
    If .wishDate2 > .wishDate3 Then
      tmpData = objData
      .wishPlace3 = .wishPlace2
      .wishDate3 = .wishDate2
      .wishPlace2 = tmpData.wishPlace3
      .wishDate2 = tmpData.wishDate3
    End If
  End With
End Sub

うーむ、我ながら吐き気を催すようなぶさいくなコードｗｗｗ

いちおう、データ入れ替えのところだけ説明します。

「バブルソート１回目」の部分、

'バブルソート１回目'
If .wishDate2 > .wishDate3 Then
  tmpData = objData    '……(1)'
  .wishPlace3 = .wishPlace2    '……(2)'
  .wishDate3 = .wishDate2    '……(3)'
  .wishPlace2 = tmpData.wishPlace3    '……(4)'
  .wishDate2 = tmpData.wishDate3    '……(5)'
End If

まず、２番目の日付と３番目の日付を比較して、２番目の方が大きかったら(1)以下で２番目の要素と３番目の要素を入れ替える。

(1)で元のデータをtmpDataに格納しておいて、
(2)、(3)で２番目だったデータを３番目のところに上書きし、
(4)、(5)でtmpDataに避難しておいたデータを用いて２番目のところに元々３番目だったデータを上書きする
という段取り。

構造体変数を引数にするときには、参照渡ししかできないみたいなので、Functionにする必要がなかった。

このプロシージャを呼び出して並べ替える。そのためのコードがコチラ。

リスト４

For i = 0 To 4
  Call sortDataByDate(wsData(i))
Next

これだけです。Forループで i 番目のwsDataを渡しています。

シートに書き出す

今回は、別の場所に転記先の表を作った。

リスト５

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
    'バブルソート１回目'
    If .wishDate2 > .wishDate3 Then
      tmpData = objData
      .wishPlace3 = .wishPlace2
      .wishDate3 = .wishDate2
      .wishPlace2 = tmpData.wishPlace3
      .wishDate2 = tmpData.wishDate3
    End If
    'バブルソート２回目'
    If .wishDate1 > .wishDate2 Then
      tmpData = objData
      .wishPlace2 = .wishPlace1
      .wishDate2 = .wishDate1
      .wishPlace1 = tmpData.wishPlace2
      .wishDate1 = tmpData.wishDate2
    End If
    'バブルソート３回目'
    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

ざっとこんな感じ。

ソースコード

リスト１

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クラスについては、

akashi-keirin.hatenablog.com

を参照。

(2)では、そのDataExtractorクラスのextractDataメソッドを使って試験範囲の分の問題だけを「抽出」シートに抽出している。

元データの範囲、条件指定セルの範囲、抽出先ラベル、の３つのRangeオブジェクトを指定するだけで抽出ができるので、これは案外便利かも知れんｗ

リスト２

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

こちらのプロシージャについては、

akashi-keirin.hatenablog.com

を参照。

リスト３

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メソッドを使っているだけなので、説明不要と思う。

リスト４

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, "ＭＳ Ｐゴシック")
    '問題データを問題様式に貼り付ける'
    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)からの８行

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)：テキストの折り返し

フォント情報や下線情報を保持したまま貼り付けるために書式ごと貼り付けると、問題様式側の書式が死ぬので、貼り付けた直後に設定し直す、といった流れになっている。もっとうまいやり方がありそうだけど。

リスト５

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

こちらについては、

akashi-keirin.hatenablog.com

をどうぞ。

実行結果

「問題データ」シートに、

こんなふうに問題データを準備。

「抽出」シートは、

こんな具合に抽出用の項目ラベルと条件指定用セルを準備。

んで、下記のコードで実行した。

Option Explicit

Dim orgSh As Worksheet
Dim extractSh As Worksheet

Public Sub main()
  Call extractQuestions
  Call setRandomNumber
  Call setQuestions
End Sub

おお、うまいことできとる！

Excelの画面上ではガタガタだけれど、PDFにしてみると、

まあまあいい感じではないでしょうか。

おわりに

もっとサクッとできると思っていたけど、縦書きにしないといけないこともあって、案外手間取ってしまった。

しかし、けっこう使い慣れてきたと思っていたExcelVBAにも未知のオブジェクトがたくさんあってちょっとびびってしまった。達人への道のりは長いなあ……。

@akashi_keirin on Twitter

セル内のアンダーライン部分のみフォントを変える

文字列のうち、アンダーライン部分のフォントだけを変える

ツイッターのフォロワーさんの「漢字テストの問題をランダムに作成できんかなー」みたいなツイートに反応して、どうやったらできるのか考えてみた。

傍線部分だけゴシックにしないといけない

文字列に下線（傍線）を引くのは自動化できないにしても、下線部だけを狙い撃ちでフォントを変えるというのは、手作業でやると死ぬほどめんどくさい。

しかし、普段文字単位で書式をいじくることなんて皆無だから、どうしていいのか分からなかった。んで、調べてみると、Charactersオブジェクトを取得して書式を施せばよいと分かった。

参考

Characters オブジェクトを使用すると、文字列のうちの一部だけを対象にした修正ができます。

Characters オブジェクトを取得するには、Characters(start, length) プロパティを使用します。引数 start には開始する文字の先頭位置の番号を指定します。引数 length には、文字数を指定します。

ということなので、なんとかなりそう。

考え方

次のような考え方でコードを書くことにした。

1. １文字目から順番にチェックする
2. 初めてアンダーラインのある文字にぶつかったときにフラグを立て、何文字目かを変数tmpStartに記録する
3. アンダーラインのない文字にぶつかったら、何文字目かを変数tmpEndに記録してループを抜ける
4. Charactersオブジェクトの引数startにtmpStartを、引数lengthにtmpEnd - tmpStartを渡すと、アンダーライン部分のCharactersオブジェクトが取得できる
5. 後は、4.で得られたCharactersオブジェクトのFontプロパティをあれこれいじくる

と、こんな感じ。

実装

リスト１

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のセル内の文字列に関するしちめんどくさい作業のかなりの部分を軽減できるようになるかも知れない。

いづれは、クラスを作って手軽に扱えるようにしてみたい。

@akashi_keirin on Twitter