条件付き書式をまじめに勉強してみた(2)

自動記録されたコードを編集する

前回

akashi-keirin.hatenablog.com

のつづき。

仕様

まず、自動記録されたコードは、Ａ３セルの値しか条件判定に使うことができない、というおっそろしくしょぼいものなので、選択範囲内全てにＡ列のセルの値次第で書式設定をするというものに変える。仕様としては、とりあえず

• 選択された範囲について、Ａ列の日付が土曜日か日曜日だったら、その行全てを薄いグレーで塗りつぶす。

というものにする。

元のコード

自動記録されたコードを再掲する。

リスト１

Sub Macro1()
  Cells.FormatConditions.Delete    '……(1)'
  Range("A3").Select
  Selection.FormatConditions.Add _
    Type:=xlExpression, _
    Formula1:= _
      "=OR(WEEKDAY($A$3)=1,WEEKDAY($A$3)=7)"    '……(2)'
  Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority    '……(3)'
  With Selection.FormatConditions(1).Interior    '……(4)'
    .PatternColorIndex = xlAutomatic    '……(5)'
    .ThemeColor = xlThemeColorDark1    '……(6)'
    .TintAndShade = -0.14996795556505    '……(7)'
  End With
  Selection.FormatConditions(1).StopIfTrue = False    '……(8)'
End Sub

コードの改良

まずは、(1)。

Cells.FormatConditions.Delete

これだと、シート上の全セルの条件を消してしまうことになる。いくらなんでもこれは乱暴なので、

Selection.FormatConditions.Delete

と、選択範囲内の条件を削除するにとどめる（でいいんですよね？）。

んで、(2)。

Selection.FormatConditions.Add _
    Type:=xlExpression, _
    Formula1:= _
      "=OR(WEEKDAY($A$3)=1,WEEKDAY($A$3)=7)"

これだと、条件判定に使えるセルがＡ３セル決め打ちになってしまうので変える。

あと、選択範囲内の全てのセルに条件設定をしないといけないので、For Each ～ Nextを使う。

Dim objCell As Range
For Each objCell In Selection
  objCell.FormatConditions.Add _
    Type:=xlExpression, _
　　Formula1:="=OR(WEEKDAY(A" & objCell.Row & ")=1," & _
              "WEEKDAY(A" & objCell.Row & ")=7)"
  objCell.FormatConditions(1)_
      .Interior.Color = myLightGray
Next

といったところか。

ちなみに、「myLightGray」ってのはユーザー定義定数ってやつで、モジュールの宣言セクションに

Const myLightGray As Long = 14277081

と記述してある。

14277081というナゾの数字は、

こうしてから、

こうやって求めた。

これで、書式設定したい行に応じて選択範囲内全てのセルに条件付き書式の設定ができる。

ところで、元のコードの(3)～(8)、すなわち、

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority    '……(3)'
With Selection.FormatConditions(1).Interior    '……(4)'
  .PatternColorIndex = xlAutomatic    '……(5)'
  .ThemeColor = xlThemeColorDark1    '……(6)'
  .TintAndShade = -0.14996795556505    '……(7)'
End With
Selection.FormatConditions(1).StopIfTrue = False    '……(8)'

は、(4)を除いてばっさりポアｗ

だって、何の役に立ってるんだか分からないんだものｗ

これで、全体のコードはこうなる。

リスト２

Sub setFormatConditionTest()
  Selection.FormatConditions.Delete
  Dim objCell As Range
  For Each objCell In Selection
  objCell.FormatConditions.Add _
    Type:=xlExpression, _
　　Formula1:="=OR(WEEKDAY(A" & objCell.Row & ")=1," & _
              "WEEKDAY(A" & objCell.Row & ")=7)"
    objCell.FormatConditions(1)_
      .Interior.Color = myLightGray    '……(*)'
  Next
End Sub

ただ、どうも(*)のところがどうも気にくわない。なんか、ブサイクなんですよ。

んで、しばらくggってみたところ、FormatConditionオブジェクトの取得については、コチラによると、

FormatConditionsコレクションオブジェクトのAddメソッドは実行されると、Addメソッドで新たに追加されたばかりのFormatConditionオブジェクトを返してきます。

ということらしいので、Addメソッドの返り値であるFormatConditionオブジェクトを即変数にセットしてしまえばよいと分かった。たとえば、

Dim tgtFormatCondition As FormatCondition
Set tgtFormatCondition = _
	objRange.FormatConditions.Add _
    (Type:=xlExpression, _
     Formula1:= _
		  "=OR(WEEKDAY($A$3)=1,WEEKDAY($A$3)=7)")

とすれば、Ａ３セルに条件をセットしたのと同時にその条件を変数にセットしたことになるわけだ。

あとは、変数tgtFormatConditionを利用して条件を満たす場合の書式を書けばよい。

そうして書き換えたのがコチラ。

リスト３

Sub setFormatConditionTest()
  Selection.FormatConditions.Delete
  Dim objCell As Range
  Dim tgtFormatCondition As FormatCondition    '……(1)'
  For Each objCell In Selection
    Set tgtFormatCondition = _
      objCell.FormatConditions.Add _
        (Type:=xlExpression, _
         Formula1:="=OR(WEEKDAY(A" & objCell.Row & ")=1," & _
                   "WEEKDAY(A" & objCell.Row & ")=7)")    '……(2)'
    tgtFormatCondition.Interior.Color = myLightGray
  Next
End Sub

ずいぶんスッキリしたぞ。

リスト３の説明

(1)の

Dim tgtFormatCondition As FormatCondition

は、FormatCondition型の変数tgtFormatConditionの準備。こんな型があったんですねえ。

(2)の

Set tgtFormatCondition = _
  objCell.FormatConditions.Add _
    (Type:=xlExpression, _
     Formula1:="=OR(WEEKDAY(A" & objCell.Row & ")=1," & _
               "WEEKDAY(A" & objCell.Row & ")=7)")

は長いけど作りは単純。右辺のFormatConditionsコレクションのAddメソッドで変数objCellが指し示すセルに条件を設定し、ということはつまり、新たにFormatConditionオブジェクトを作り出して、変数tgtFormatConditionにセットしているだけ。

TypeとかFormula1というのはAddメソッドの引数で、それぞれ数式を条件とすること、その数式、を表している。

ちなみに、Formula1プロパティの値を

"=OR(WEEKDAY(A" & objCell.Row & ")=1," & _
"WEEKDAY(A" & objCell.Row & ")=7)")

と、「=1,」の後ろで一旦ダブルクオーテーションを閉じて行継続文字で改行しているが、これは単に可読性だけの問題。本来こんなところで改行する必要はない。

実行

範囲を選択して、マクロを実行すると、

ほれ、この通り、条件付き書式が適用されている。

おわりに

まだまだ決め打ちみたいな処理しかできないので、もっと柔軟な処理ができるようにしたいなあ。

条件付き書式をまじめに勉強してみた

条件付き書式を設定するマクロ

年度最終日、さっさと仕事を済ませて華麗に帰ってやろうと思っていたのだが、新年度すぐに使う予定表に一つ機能を付け加え忘れていたことに気づいた。ワンクリックで１年分のカレンダーが更新されるようにしていたのに、土日のセルの色を変える条件付き書式を設定し忘れていたのだった。

ついこないだまでExcelど素人だった私。条件付き書式は普段あまり使うことがないので、いざやろうとしたら結構時間がかかってしまったのだった。

結局、単純作業の繰り返しに陥ってしまったので、以後こんなことにならないよう、自身の勉強も兼ねてブログに書いておくことにした。

マクロ記録してみる

まずは、Ａ３セルに入っている日付が、土曜日か日曜日だったら、セルの背景を明るいグレーにする、という条件付き書式の設定をマクロ記録してみた。

「条件付き書式」→「ルールの管理」の順にクリックしたら、

こんなのが出てくるので、この画面で「新規ルール」をクリック。

すると、こんなやつが出てくるので、「数式を使用して、書式設定をするセルを決定」を選んで、「次の数式を満たす場合に値を書式設定」（変な日本語だな、オイ）欄に今回は、

OR(WEEKDAY($A$3)=1,WEEKDAY($A$3)=7)

を入力。「Ａ３セルの日付が土曜日か日曜日だったらTrue」という条件だ。

次に、「書式」ボタンをクリックすると、

こんなのが出てくるので、明るいグレーのところ（赤枠のところね）をクリックして[ＯＫ]。そうしたら、

こんなふうになる。これで[ＯＫ]をクリックしたら設定完了。ここでマクロ記録終了。

ちなみに、ワークシート上ではこうなっている。画像のトリミングの仕方がおかしいな、オイ！　グレーになっているところがＡ３セルです。

自動記録されたコード

んで、できたのが次のコード。改行とかタブとかちょっと整えてるけど。

リスト１

Sub Macro1()
  Cells.FormatConditions.Delete    '……(1)'
  Range("A3").Select
  Selection.FormatConditions.Add _
    Type:=xlExpression, _
    Formula1:= _
      "=OR(WEEKDAY($A$3)=1,WEEKDAY($A$3)=7)"    '……(2)'
  Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority    '……(3)'
  With Selection.FormatConditions(1).Interior    '……(4)'
    .PatternColorIndex = xlAutomatic    '……(5)'
    .ThemeColor = xlThemeColorDark1    '……(6)'
    .TintAndShade = -0.14996795556505    '……(7)'
  End With
  Selection.FormatConditions(1).StopIfTrue = False    '……(8)'
End Sub

うひゃあ、相変わらずイヤーなコードだｗ　見たことないようなプロパティが多いしｗ

何やってんだか解読してみよう。

リスト１の説明

まず、(1)なんだが、

Cells.FormatConditions.Delete

ん？　Cells？……ってことは、一旦全てのセルの条件を削除しちまってるのか！？　ってことは、安易に実行したら消されちゃ困る条件まで巻き添えで消されてしまうってことなのか？？？

で、(2)

Selection.FormatConditions.Add _
    Type:=xlExpression, _
    Formula1:= _
      "=OR(WEEKDAY($A$3)=1,WEEKDAY($A$3)=7)"

ちょっと行継続文字をこまめに入れてある。選択中のセル（Selection）のFormatConditionsコレクションに、AddメソッドでFormatConditionオブジェクトを追加している。

引数のTypeってのはよく分からないんだけど、

によると、定数「xlExpression」が「演算」という意味のようだから、「数式を使用して、書式設定するセルを決定」を選んだ、という意味なんだろう。

んで、(3)。

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority

FormatConditionsコレクションのインデックスに「Selection.FormatConditions.Count」を渡している。(1)で一旦FormatConditionをクリアした後、(2)のAddメソッドでFormatConditionオブジェクトを追加しているんだから、当然この時点でCountプロパティの値は「1」。要するに、さっき新たに追加したFormatConditionオブジェクトを指しているということなんだな……。

なんでこんなめんどくせーことするんだ？？？

すみません。取り乱しました。要するに、(2)で新たに追加したFormatConditionオブジェクトのSetFirstPriorityメソッドを使っているわけだが、

条件付き書式ルールの優先度の値を "1" に設定し、ワークシート内の他のルールより先に評価されるようにします。

……。これ、いる？？？

優先も何も、条件１つしかないのに……。

次は、(4)。

With Selection.FormatConditions(1).Interior

って、今度はFormatConditionsコレクションのインデックスは「1」なのかよｗ　さっきの「Selection.FormatConditions(Selection.FormatConditions.Count)」ってのは何だったんだ？？？

それはともかく、FormatConditionオブジェクトのInteriorプロパティまでをWithでまとめているので、ここから先はセル（今回の場合はＡ３セル）の見た目を操作していくことになるはず。

(5)～(7)はいっぺんに行こう。

.PatternColorIndex = xlAutomatic    '……(5)'
.ThemeColor = xlThemeColorDark1    '……(6)'
.TintAndShade = -0.14996795556505    '……(7)'

は、は～～～ん？？？

何でColorプロパティがないんだ？？？

すまん。(5)については、たぶん、

ということなんだと思う。

(7)については、

色を明るく、または暗くする単精度浮動小数点型 (Single) の値を設定します。

ということだそうだから、マクロ記録にありがちな

デフォルトで何ら問題なくて普段意識することすらないプロパティの設定をバカ正直にやっている

というだけのことだろう。

しかしながら、(6)はさっぱり分からん。

それ以上になんでColorプロパティに関する記述がないのか、もっと分からん。だれか、詳しい人は教えろてください。

またしても取り乱してしまった。気を取り直して(8)。

Selection.FormatConditions(1).StopIfTrue = False

StopIfTrueというのは、「条件を満たす場合は停止」のチェックのことで、こういうことらしい。

複数条件があるようなときは、結構重要なんだろうが、今回のように条件式が１つしかないときは、別にどうでもいいよね？

次回予告

う～～～ん、思ってた以上に手強いぞ、条件付き書式。

次回から、このコードを改良していこう。

akashi-keirin.hatenablog.com

画像をクリックしたら画像のあるセルに現在時刻を書き込むマクロ

クリックされた図形のあるセルを取得する

前置き

「画像をクリックしたら、その画像のあるセルに現在時刻を書き込むようなことってできない？」と言われたのでやったことがあった。

Excelで勤怠管理の一覧表を作って、出勤時と退勤時にその日の欄にある画像をクリックするだけで時刻を書き込めるように、ということらしい。

ちょこちょこっとggってみると、こんなのが引っかかった。なるほど、画像にマクロを登録して、そのマクロの中でApplication.Callerというプロパティの値を取得すれば、マクロの呼び出し手、すなわちマクロを登録した画像そのものが取得できるわけだな。ややこしい言い方ですまん。

あと、こういうのも引っかかってくる。

コチラによると、shapeオブジェクトにはTopLeftCellという非常に便利なプロパティがあり、

オブジェクトの左上端にあるセルを表す Range オブジェクトを返します

ということだ。

前置きが長くなったけど、要するに、

1. セルの中に画像を置く
2. クリックされた画像の左上端のあるセルに現在時刻を書き込むマクロを作る
3. 画像に(2)で作ったマクロを登録する

というやり方でいけるはず。

マクロの作成

Application.Callerプロパティ、shapeオブジェクトのTopLeftCellプロパティという非常に便利なものがあるおかげで、めちゃくちゃ簡単なコードでいけそう。

リスト１

標準モジュールに次のコードを書く。

Option Explicit

Sub setTimeByButtonClick()
  Dim strAddress As String
  With ActiveSheet
    strAddress = _
      .Shapes(Application.Caller).TopLeftCell.Address    '……(1)'
    .Range(strAddress).Value = Now()    '……(2)'
  End With
End Sub

なんと、たったのこれだけｗ

リスト１の説明

まず、Application.Callerがこのマクロの呼び出し元のオブジェクト名を返すから、Shapesコレクションのインデックス（？）のところにApplication.Callerを入れてやることで、マクロ呼び出し元画像オブジェクト（＊）を取得することができる。

んで、（＊）のTopLeftCellプロパティは、オブジェクトの左上端にあるセルを表す Range オブジェクトを返しますということなので、そのAddressプロパティを取得してやれば、セルの番地が得られることになる。

ごく短いコードだけど、ここまでを理解しておくことが前提かな。

• (1)では、上記のように、
  クリックされた画像オブジェクトの取得→画像オブジェクトの左上端のあるセルの取得→セルのアドレス文字列を取得
  の順でクリックされた画像のあるセルのアドレスを取得して変数strAddressに格納している。
• (2)では、Rangeプロパティの引数に(1)で取得したアドレス文字列を指定してセルを取得し、そのValueプロパティにNow関数によって現在日時をセットしている。

(2)でTimeではなくNowにしたのは、日付が変わってから退勤する場合に備えるため。

実行

画像をクリックすると、

時刻が無事に書き込まれた。

おわりに

ごく短いコードだったけれど、知っておくと便利な要素が結構詰まっている気がする。

@akashi_keirin on Twitter

小さなクラスを作る(7)～セルの列符号が簡単に取得できるラッパークラス

列符号取得が可能なRangeオブジェクトのラッパークラス

きっかけ

「列番号はColumプロパティで簡単に取得できるのに、列符号って取り出しにくいよなー」と思って、コチラを参考にXDF列までに対応した自作関数を作ったのがそもそもの始まり。

他のよく使う機能を一つのモジュールにまとめて使い回していたんだが、モジュール内のプロシージャが増えるにつれ、管理がいい加減になってしまって、放置プレーになってしまっていた。

ブックＡに仕込んだ○○プロシージャは修正したけど、ブックＢの○○プロシージャは以前のまま、みたいな。

ちょうどクラスモジュールの練習中でもあるので、

一つのセルを包み込んで、列符号を尋ねたら応えてくれて、なおかつRangeオブジェクトの諸機能もそのまま使える

クラスを作ってみようと思い立った。

これを「ラッパークラス」と呼んでよいものかどうかは自信がないので、達人のみなさん、ツッコミよろしく！

準備

クラスモジュールを挿入して、オブジェクト名を「WrappedCell」にする。

リスト1-1　宣言セクション

Option Explicit
'自作エラー情報のための構造体    '……(1)'
Private Type errorType
  Number As Long
  Description As String
End Type
'拡張できるように配列で宣言    '……(2)'
Private myError() As errorType
'エラーインデックス用の番号を列挙体で準備    '……(3)'
Private Enum errIndex
  CELL_NOT_SINGLE = 0 'セルが複数渡された
  CELL_NOT_GOT  'セル未取得
End Enum

リスト1-1の説明

まずは下ごしらえ。普通はフィールドの宣言から始めるけど、今回はちょっと違う。

• (1)では、自作エラーを表示するために、ErrオブジェクトのRaiseメソッドの引数用の構造体を準備した。まあ、たった２つのパラメータごときを構造体にまとめるというのは鶏を割くに牛刀を用いるの観なきにしもあらずだが、使わないと忘れるので。
• (2)では、(1)で準備したerrorType型の変数myErrorを配列で準備している。あとで自作エラーの種類を増やすときに楽なようにこうした。他にもエラーを吐かせるべきことがあるかも知れんので。いわゆるYAGNIの原則には反しますがｗ
• (3)では、 id:imihitoさんのこのとき
のアドヴァイス

処理のブロックに番号をつけるときに列挙型（Enum）を使うと、識別子を付けられるのでただの数字より見やすくなってオススメ

を生かして配列myErrorのインデックス番号を列挙体で準備した。今後、エラーの種類を増やすときは、ここで番号に意味のある文字列を割り振ったら良い。

リスト1-2　フィールド

'フィールド
Private oneSelf_ As Range
Private columnLetter_ As String

リスト1-2の説明

とりあえず、包み込む対象のセルそのものと、そのセルの列符号をフィールドとして持たせることにした。他になんかあるだろうか？？？

リスト1-3　アクセサ(1)

'アクセサ
Public Property Set oneSelf(ByRef newCell As Range)
  If newCell.Count <> 1 Then    '……(1)'
    Call raiseError(errIndex.CELL_NOT_SINGLE)    '……(2)'
    Exit Property
  End If
  Set oneSelf_ = newCell    '……(3)'
End Property
Public Property Get oneSelf() As Range
  If oneSelf_ Is Nothing Then    '……(4)'
    Call raiseError(errIndex.CELL_NOT_GOT)    '……(5)'
  End If
  Set oneSelf = oneSelf_
End Property

リスト1-3の説明

珍しくProperty Set(Let)を書いた。

Javaファンの私からすると、Propertyプロシージャってなんだかヘンテコリンな感じがするので、別途Setterメソッドを作るという手もあったんですけどね。

• (1)では、このクラスに渡されるRangeオブジェクトをチェック。
• このクラスは、あくまでも単一のセルを包み込むのが目的なので、複数セルが渡されたら(2)でエラーを吐かせる。プログラマに知らせることが目的なのであえてエラーを吐かせるのだ。
  エラー表示用のraiseErrorメソッドは後で実装する。
• (1)のIf節を何事もなく通過したら(3)で仮変数oneSelf_に渡されたセルをセットしている。
  ちなみに、(1)のIfに対応したElse節内に書くこともできるが、あえてこうしている。
  というのも、「If～Else」を多用すると可読性が落ちる（Elseの条件は、If、ElseIfと見比べないと分からない）ため。「ガード節」というらしい。たしかに「If～Else」って読みにくいときがあるんだよな。
• (4)も(1)と同じ。oneSelfプロパティにセルがセットされていないのに呼び出そうとしたら(5)でエラーを吐く。まあ、なくても普通にエラーが出るだろうけど、こうした方が原因が特定しやすいと思うので。

リスト1-4　アクセサ(2)

Public Property Get columnLetter() As String
  If oneSelf_ Is Nothing Then
    Call errorRaiser(errIndex.CELL_NOT_GOT)
    Exit Property
  End If
  Dim iAlpha As Integer       '列符号最上位けた'
  Dim iBeta As Integer        '列符号中位けた'
  Dim iRemainder As Integer   '列符号最下位けた'
  With oneSelf_
    If .Column > 702 Then '列番号が702を超えるとき、列符号は３けた    '……(1)'
      iAlpha = Int((.Column - 27) / 676)    '……(2)'
      columnLetter_ = Chr(iAlpha + 64)    '……(3)'
      iBeta = Int(((.Column - (iAlpha * 676)) - 1) / 26)    '……(4)'
      columnLetter_ = columnLetter_ & Chr(iBeta + 64)
      iRemainder = (.Column - (iAlpha * 676) - (iBeta * 26))
      columnLetter_ = columnLetter_ & Chr(iRemainder + 64)
    ElseIf .Column > 26 Then  '列番号が26を超えるとき、列符号は２けた    '……(5)'
      iBeta = Int((.Column - 1) / 26)
      columnLetter_ = Chr(iBeta + 64)
      iRemainder = .Column - (iBeta * 26)
      columnLetter_ = columnLetter_ & Chr(iRemainder + 64)
    Else  '列番号26までは列符号１けた    '……(6)'
      iRemainder = .Column
      columnLetter_ = Chr(iRemainder + 64)
    End If
  End With
  columnLetter = columnLetter_
End Property

リスト1-4の説明

ココが今回のメイン。列番号の取得はめっちゃ簡単なのに、列符号の取得のなんとメンドウなことよ。高校１年程度の数学ができるんならこのコードは理解できると思う。(1)～(3)がどうしても理解できないんならあきらめてください。

• (1)。まず、１列目（Ａ）～26列目（Ｚ）は列符号１けた。これは楽勝ですな。んで、27列目（AA）から702行目（ZZ）が列符号２けた。
  アルファベット２字の組み合わせは26×26＝676通り。AAから数えて676番目のZZは、そこまでの26を足して702番目になるでしょ？
• (2)は、列符号の左端の文字を求めるための計算。ZZ（702列目）の次がAAA（703列目）ってのがミソ。
  703列目以降は、BAA列が（27＋676）＋676＝1379列目、CAA列が（27＋676）＋676＋676＝2055列……というように、左端のアルファベットが進んでいくので、左端のアルファベットは[列数－27を676で割った商]番目のアルファベット、ということになる。
• 何番目のアルファベットかさえわかれば、あとは、その数字を文字に変換してやればよい。アルファベットの大文字「A」は文字コードが65番目なので、Chr関数の引数に[(2)で求めた数＋64]を渡してやれば、めでたくアルファベットが得られる。
• (1)～(3)が理解できるなら、(4)はもはや説明不要だろう。
  列番号から676のかたまりを除去すると、後は右の２けたの問題ですからね。
  AAA列を例にとると、703－676－1＝26、26÷26＝１なので、真ん中のアルファベットは１番目、すなわちＡということ。
• (5)は２けたになるとき、(6)は１けたになるとき、それぞれ同じような理屈で文字に変換している。

リスト1－5　コンストラクタとメソッド

'コンストラクタ
Private Sub Class_Initialize()
  ReDim myError(2) As errorType    '……(1)'
  With myError(0)
    .Number = 10000
    .Description = "WrappedCellのoneSelfプロパティに複数のセルを渡すことはできません。"
  End With
  With myError(1)
    .Number = 10001
    .Description = "WrappedCellのoneSelfプロパティにセルがセットされていません。"
  End With
End Sub
'メソッド
Private Sub raiseError(ByVal errIndex As Integer)    '……(2)'
  Err.Raise myError(errIndex).Number, myError(errIndex).Description
End Sub

リスト1－5の説明

珍しくコンストラクタの出番。このクラス独自のエラーをセットしている。

• (1)では、今のところエラーの種類は２種類だけなので、RedimしてそれぞれNumberとDescripitionをセットしている。
• (2)は、自作エラーを吐かせるメソッド。クラスの内部でしか使わないのでPrivateにしている。こんなもん、あっちこっちで使われたらかなわんしｗ
  引数として配列のインデックス番号を受け取って、それに応じたNumberとDescriptionをセットしているだけ。

実行

標準モジュールのコード

Sub test05()
  Dim target As WrappedCell
  Set target = New WrappedCell
  Set target.oneSelf = Selection
  Debug.Print target.columnLetter
  Set target = Nothing
End Sub

実行結果

セルを選んで、実行すると、

ほれ、この通り列符号が取得できた。

結合されたセルでも

大丈夫。

ただし、複数セルを選択して実行すると

エラーを吐く。

「[WrappedCellクラスのインスタンス].oneSelf.」まで入力すると、

このようにインテリセンスが働くので、Rangeオブジェクトのプロパティ・メソッドが普通に使える。

おわりに

とりあえず、何の役に立つのか分からないけど、今後拡張できたらしてみよう。

……とここまで書いてきてアレなんだが、

セルの列符号ぐらい、もっと簡単に取得できるんじゃね？

と思ってしまったのだった。

リスト2

Sub test06()
  Dim tgtCell As Range
  Set tgtCell = ActiveCell
  Dim str As String
  Dim chr As String
  Dim i As Integer
  Dim tmp As String
  str = Replace(tgtCell.Address, "$", "")
  For i = 1 To Len(str)
    chr = Mid(str, i, 1)
    If chr Like "[0-9]" Then
      chr = ""
    End If
    tmp = tmp & chr
  Next
  str = tmp
  Debug.Print str
End Sub

リスト2の実行結果

AZN５セルを選択して実行すると、

でけとる……。

む、むなしい……orz

@akashi_keirin on Twitter

フォルダ構成を別のフォルダにコピーするマクロ(3)

一覧表のデータを元にフォルダ構成を移植する

いよいよ今回のマクロも完成。

今回は、前回のマクロで作成したフォルダの一覧表を元に、別のフォルダにフォルダ構成を再現する処理を書いていく。

処理の下準備

リスト1-1

Sub moveFolderStructure()
  Dim objSh As Worksheet
  Set objSh = ActiveSheet
  With objSh
    If .Range("A3").Value = "" Then    '……(1)'
      MsgBox "フォルダフルパスが空白なので処理できません。", vbCritical
      Exit Sub
    End If
    Dim lastRw As Integer
    lastRw = .Cells(Rows.Count, 1).End(xlUp).Row    '……(2)'
  End With

リスト1-1の説明

処理を始めるための準備みたいなところ。

• (1)は、Ａ３セルが空白かどうかで条件分岐。Ａ３セルに何も入っていなければ、そもそもフォルダ構成が取得できていないということなので、メッセージを表示して処理を終える。
• (2)はおなじみ、データのある最終行番号を求める計算。データ転記系の処理ではマジでよく使うので、入門者は理屈とともに手が勝手に動くレベルまで習熟すべし。

コピー先の親フォルダのフルパス取得

当ブログではもはやおなじみ、FolderPickerクラスを使う。

リスト1-2

  Dim rootPath As String
  Set fldPicker = New FolderPicker    '……(1)'
  MsgBox "フォルダ構成のコピー先となる親フォルダを指定せよ。"
  With fldPicker
    .showFolderPicker    '……(2)'
    If .isCancelled = True Then    '……(3)'
      Exit Sub
    End If
    rootPath = fldPicker.gotFolder    '……(4)'
  End With

リスト1-2の説明

もはや説明不要かも知れんけど、一応。

• (1)はおなじみ、FolderPickerクラスをインスタンス化。ひつこいようだけど、ここから先は変数fldPickerをさながらフォルダパス等の取得屋さんのように使える。
  「fldPickerさ～ん、ちょっとフォルダ選択ダイアログを表示して～！」とか、「fldPickerさ～ん、フォルダのフルパスを教えて～！」みたいな感じ。クラスを作るメリットの一つだと思う。
• (2)がまさに「fldPickerさ～ん、ちょっとフォルダ選択ダイアログを表示して～！」。
• (3)の「fldPicker.isCancelled」の取得は「fldPickerさ～ん、キャンセルされた？」てな感じ。
• (4)は、さしづめ「fldPickerさ～ん、ちょっと選択されたフォルダのフルパスを教えて？　rootPathに代入すっからさ！」てな感じかな。

「クラス」というものを使うと、まるでオブジェクトと会話するような感じでプログラミングできる、というメリットがある。もちろん、クラス名やフィールド名、メソッド名を適切につけた場合に限るんだろうけど。

フォルダ構成の複製

いよいよここからがメインの処理。

リスト1-3

  Dim i As Integer    '……(1)'
  Dim n As Integer    '……(2)'
  Dim strPath As String    '……(3)'
  With ObjSh
    For i = 3 To lastRw    '……(4)'
      n = 2    '……(5)'
      strPath = .Cells(i, n).Value    '……(6)'
      Do While .Cells(i, n).Offset(0, 1).Value <> ""    '……(7)'
        strPath = strPath & "\" & _
                    .Cells(i, n).Offset(0, 1).Value    '……(8)'
        n = n + 1    '……(9)'
      Loop
      strPath = rootPath & "\" & strPath   '……(10)'
      If Dir(strPath, vbDirectory) = "" Then   '……(11)'
        MkDir strPath   '……(12)'
      End If
    Next
  End With
  MsgBox "フォルダ構成の複製が終わりました。"
End Sub

リスト1-3の説明

• (1)でループカウンタ i を宣言。一覧表を行方向に進んでいくのに使う。
• (2)でループカウンタ n を宣言。コチラは、一覧表を列方向に進んでいくのに使う。
• (3)は、フォルダパスを格納するのに使う変数。
• (4)は、行方向のループ設定。３行目から最終行まで回す。
• (5)で n の初期値を設定。今回使用するワークシートでは、Ａ列、すなわち１列目には元のフォルダのフルパスが入っている。個々のフォルダ名は２列目以降に入っているので、n の初期値は 2 となる。
• (6)で、まず i 行目の１つ目（Ｂ列）のフォルダ名をstrPathに格納。
• (7)は、(7)からの５行（実質４行）のDoループの継続条件。１つ右のセルが空白になるところまで右へ右へ進んでいくイメージ。
• (8)では、１つ右のセルに入っているフォルダ名を、アタマに「\」をつけてstrPathに連結している。
  たとえば、strPathに「A」、１つ右のセルに「B」が入っていたら、この段階でstrPathの中身が「A\B」（＝Aフォルダの中にあるBフォルダ）になっているということ。
• (9)で n をインクリメント。
• (7)のDoループを抜けた段階で、strPathにはサブフォルダのフォルダパスが格納されているので、あとは(10)で、そのアタマに、移動先のフォルダパスと「\」を連結してやれば、サブフォルダのフルパスができる。
• (11)で既にそのフォルダがあるかどうかを判定し、なければ(12)のMkDirステートメントで作成する。

あとは、 i が最終行番号に達するまで繰り返す。こうすることで、新たにフォルダ構成だけを指定のセルに書き込むことができる。

実行

ボタンをクリックしてマクロ起動。

フォルダを選べ、と言われるので、

フォルダを選択すると、

あっという間に完了。

「ち～んｗ」フォルダ内にフォルダができている。Bフォルダの中にC、Dフォルダがあることが分かる。Eフォルダもある。

おわりに

同じフォルダ構成を繰り返し用いる業務があるなら、ファイルはコピーせずにフォルダ構成だけを複製することができるこのマクロはなかなか便利だと思う。

@akashi_keirin on Twitter

フォルダ構成を別のフォルダにコピーするマクロ(2)

指定したフォルダ内のフォルダ構造をワークシートに書き出す

標準モジュールの宣言セクション

リスト1-1

Option Explicit
Dim fldPicker As FolderPicker

おなじみ、変数宣言の強制と、FolderPickerクラスのインスタンス用の変数宣言。FolderPickerクラスについては、コチラをどうぞ。

セルのクリアとラベルの書き込み

リスト1-2

Sub copyStructureFromOrg()
  Dim objSh As Worksheet
  Set objSh = ActiveSheet    '……(1)'
  With objSh
    .Cells.ClearContents    '……(2)'
    .UsedRange.Borders.LineStyle = xlNone    '……(3)'
    .Range("A2").Value = "フォルダフルパス"    '……(4)'
    .Columns("A").ColumnWidth = 40    '……(5)'
  End With

リスト1-2の説明

• (1)で、アクティブシートをオブジェクト変数にセット。
• (2)で一旦全てのセルの内容をクリア。
• (3)で全ての罫線をクリア。こういうときにはUsedRangeプロパティが便利。
  ちなみに、UsedRangeは文字通り使用中のセル、Bordersはセルの境界線のコレクションで、「セルの辺みんな」ぐらいの理解でいいと思う。
• (4)でＡ２セルに「フォルダパス」と書き込んでいる。シートの２行目はラベル領域なんだけど、この程度なら毎回書き直しても大した手間ではないので、一旦消してから毎回書き込むようにしている。
• (5)で、Ａ列の列幅を「40」にしている。まあ、「40」という数字に深い意味はない。

フォルダ構成コピー元フォルダの指定

FolderPickerクラスを使う。

リスト1-3

  With objSh
    Set fldPicker = New FolderPicker     '……(1)'
    MsgBox "フォルダ構成のコピー元となる親フォルダを指定せよ。"
    With fldPicker
      .showFolderPicker "フォルダ選択( ﾟ∀ﾟ)"     '……(2)'
      If .isCancelled = True Then     '……(3)'
        Exit Sub
      End If
      Dim rootPath As String
      rootPath = fldPicker.gotFolder     '……(4)'
      objSh.Range("C1").Value = "←元の親フォルダ名"
      objSh.Range("B1").Value = .gotFolderName     '……(5)'
    End With
  End With

リスト1-3の説明

• (1)で、FolderPickerクラスをインスタンス化。以降、変数fldPickerでFolderPickerオブジェクトを操作することができる。
• (2)で、FolderPickerオブジェクトのshowFolderPickerメソッドを実行。引数に「フォルダ選択( ﾟ∀ﾟ)」という文字列を渡しているので、フォルダ選択ダイアログボックスのタイトル部分には「フォルダ選択( ﾟ∀ﾟ)」が表示される。
• (3)でフォルダ選択がキャンセルされたかどうか判定。キャンセルされるか、フォルダを選択せずに[ＯＫ]をクリックしていると、FolderPickerオブジェクトのisCancelledプロパティがTrueになっている。Trueだったらこのプロシージャから抜けるようにしている。
• (4)では、取得したフォルダパスを変数rootPathにセットしている。showFolderPickerメソッドの実行によりフォルダパスが取得できていたらgotFolderプロパティにフォルダのフルパスがセットされている。
• (5)でシートのＢ１セルにフォルダ名を書き込んでいる。gotFolderNameプロパティにはフォルダ名のみの文字列がセットされている。

全てのサブフォルダのフルパスをＡ列に書き込む

前回紹介したwriteAllFolderPathメソッドの出番。

リスト1-4

    Call writeAllFolderPath(rootPath)

リスト1-3の(4)で取得したrootPathを引数として渡してwriteAllFolderPathメソッドを実行。

Ｂ列以降にサブフォルダ名を階層に分けて書き込む

リスト1-5

    Dim lastRow As Integer
    lastRow = .Cells(Rows.Count, 1).End(xlUp).Row     '……(1)'
    Dim i As Integer     '……(2)'
    Dim arryPath As Variant     '……(3)' 
    Dim n As Integer     '……(4)' 
    Dim objStr As String
    With ObjSh
      For i = 3 To lastRow
        objStr = Replace(.Cells(i, 1).Value, rootPath & "\", "", _
                         Compare:=vbTextCompare)    '……(5)'
        arryPath = Split(objStr, "\")   '……(6)'
        For n = 0 To UBound(arryPath)   '……(7)'
          .Cells(i, n + 2).Value = arryPath(n)   '……(8)'
        Next n
      Next i
    End With

リスト1-5の説明

• (1)はおなじみの書き込み済み最終行番号の取得。
• (2)の「i」はループカウンタ。この後の処理で書き込み対象行番号を指すのに使う。
• (3)は、フォルダ名を階層ごとに格納するのに使う配列。
• (4)の「n」もループカウンタなんだけど、こっちは書き込み対象列番号を指すのに使う。
• (5)は、Replace関数を用いて、フォルダのフルパスからリスト1-3の(4)で取得したrootPathを除いた文字列を変数objStrにセットしている。
  指定したフォルダよりも下層にあるフォルダ構成をコピーする、という処理内容なので、指定したフォルダまでのパスは必要ないのでこうしている。
  あと、Replace関数の引数CompareにvbTextCompareを指定しているのがポイント。こうしておかないとReplace関数がネットワークドライブのドライブ名の大文字を勝手に小文字に変換してしまうのでうまくいかなかった。
• (6)では、Split関数を用いてフォルダ内各階層のフォルダ名を配列として取得。要素数が流動的なので、(3)でVariant型にしていたということ。
• だから、(7)でForループの最終値をしていするのもUbound関数を使う。
• ここまで準備をしたら、あとは(8)で、列番号（マイナス2）を表すループカウンタ「n」と、行番号を表すループカウンタ「i」を利用して各階層のフォルダ名をセルに書き込んでいく。
  階層の深さに応じて右へ右へ書き込んで行き、最下層のフォルダ名まで書き込んだら次の行へ移る、というイメージ。

ラベル書き込みとセルの並べ替え

リスト1-6

    Dim maxCol As Integer
    Dim objCell As Range
    For i = 3 to lastRow    '……(1)'
      'i行目の列数を割り出す'
      n = 1
      Do While .Range("A" & i).Offset(0, n).Value <> ""    '……(2)'
        n = n + 1
      Loop
      If maxCol < n Then    '……(3)'
        maxCol = n
      End If
    Next
    '2行目に列ラベルを書き込む'
    With objSh
      For n = 2 To maxCol    '……(4)'
        .Cells(2, n).Value = "第" & n - 1 & "階層"    '……(5)'
        .Cells(2, n).HorizontalAlignment = xlCenter    '……(6)'
        .Cells(2, n).Borders.LineStyle = xlContinuous    '……(7)'
      Next
    End With

リスト1-6の説明

• (1)では、Ａ列の３行目～記入済み最終行までForループを指定。
• (2)からの３行は、Ａ列から数えてn番目のセルが空白になるまで「n」をインクリメントする処理。
  こうすることで、Doループを抜けたときには変数nがi行目の「データの入っている最終列番号」になる。
  たとえば、Ｃ列までデータが入っていたとすると、n = 1でＢ列→ n = 2でＣ列 → n = 3 で空白のＤ列にたどり着いてループから抜けるので、ループから抜けた時点で n は 3、すなわちＣ列を表すということになる。
• (3)で n がそれまでのmaxColを上回っていればmaxColを n の値で更新する。
  これを i がlastRowになるまで繰り返せば、Forループが終わった段階でmaxColには最も階層が深いフォルダの階層数が入っていることになる。
• ここまでの処理で最大行数と最大列数が確定するので、(4)以降のループ処理に移る。
• (5)で２行目の各列にラベル名を書き込む。
• (6)では２行目各列の文字の配置を中央揃えに。
• (7)でlastRow行×maxCol列の範囲に格子状罫線を施している。

最大行数×最大列数のセル領域のうち、空白セルに「0」を書き込む

この後の処理で並べ替える際に、空白セルがあると一番下になってしまう。それを避けるため、一旦空白のセルに全て「0」を書き込むことにする。

リスト1-7

  With objSh
    Dim objRange As Range
    Set objRange = Range(.Cells(3, 1), .Cells(lastRw, maxCol))    '……(1)'
    For Each objCell In objRange    '……(2)'
      If objCell.Value = "" Then
      objCell.Value = "0"
      End If
    Next
  End With

リスト1-7の説明

• (1)で変数objRangeに各階層のフォルダ名を書き込んだセル範囲をセット。
• (2)では、おなじみのFor Each～Nextを用いて各セルを調べ、空白なら「0」を書き込む。

右端の列から昇順ソートし、一旦「0」にしたセルを空欄に戻す

右端の列から順に昇順ソートすることにより、何列あったとしても並べ替えの優先度を「左端の列→右端の列」にすることができる。

リスト1-8

    For i = maxCol To 2 Step -1   '……(1)'
      objRange.Sort key1:=.Cells(3, i), _
                    order1:=xlAscending
    Next
    For Each objCell In objRange
      If objCell.Value = "0" Then
        objCell.Value = "'0"    '……(2)'
        objCell.Value = ""
      End If
    Next

リスト1-8の説明

• (1)だが、先にも書いたとおり並べ替えの優先度の低い方から順に並べ替えをしていくことで、列数にかかわらずうまく並べ替えることができる。
• おなじみ、For Each～Nextなんだが、単純に各セルに""を書き込むだけだとなぜかセルの値が「0」扱いになり、(2)のように一旦「'」を付けて文字列にしてから""を書き込むとうまくいった。なぜだかよく分からない。

格子罫線を引いて列幅を調整

リスト1-9

  With objSh
    objRange.Borders.LineStyle = xlContinuous    '……(1)'
    .Range("A2").Borders.LineStyle = xlContinuous    '……(2)'
    .Range(.Columns(2), .Columns(maxCol)).AutoFit    '……(3)'
  End With
  MsgBox "全てのフォルダ構成が書き出されました。"
End Sub

リスト1-9の説明

• (1)で範囲内に格子罫線を施す。
• (2)では同じくＡ２セルに格子罫線を施す。
• (3)ではＢ列～最終列までの列幅を自動調整している。

実行結果

実行すると、

こんな具合にフォルダ構成が階層ごとに書き出される。

この程度ならあんまりありがたみもないんですが、

このぐらいのフォルダ数になると、かなり便利だと感じると思う。

次回予告

後は、書き出したフォルダ構成を別のフォルダに移植する処理を追加したらできあがり。お楽しみに！

フォルダ構成を別のフォルダにコピーするマクロ(1)

全てのサブフォルダのパスを書き出す

「再帰呼び出し」を使ったコード

フォルダの中にフォルダがあって、そのフォルダの中にまたフォルダがあって……というような場合に、全てのフォルダのパスを取得するためには、メソッドの「再帰呼び出し」というものを使えば良いらしい。

参考にしたのは、日経ソフトウエア誌2015年10月号の「実務で使うExcelVBA」。VBA界では超有名な武藤玄さんによる連載記事。

「日経BPパソコンベストムック」シリーズのいますぐExcelVBAが使えるようになる本にも載っている。今でもフツーに手に入ると思う。

では、コードをば。

リスト１

Sub writeAllFolderPath(ByVal basePath As String)
  Dim objSh As Worksheet
  Set objSh = ActiveSheet
  Dim objSubFolder As Object    '……(1)'
  Dim objRow As Integer
  For Each objSubFolder _
            In CreateObject("Scripting.FileSystemObject") _
              .GetFolder(basePath).SubFolders    '……(2)'
    Call writeAllFolderPath(objSubFolder.Path)    '……(3)'
    objRow = objSh.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row    '……(4)'
    objSh.Range("A" & objRow).Value = objSubFolder.Path
  Next
End Sub

コードの説明

自身の復習も兼ねて、ちょっとこってり説明しておこう。

そもそも、「FileSystemObjectオブジェクト」ってなんだかよく分からなかったんですよ。

名前からしてわけ分からないじゃないですか。ほれ、「ファイルシステムオブジェクトオブジェクト」って、「大瀬ゆめじ・うたじ・うたじ」（ナイツのネタ）みたいで。

でもまあ、オブジェクト指向とかが分かってきはじめた今なら、ちゃんと理解できるんじゃないかと説明を試みることにします。

まずはコイツ。

リスト１の(1)

Dim objSubFolder As Object

「FileSystemObject」オブジェクトってのは、「ファイルシステムに関するアレ」みたいなふうにとらえたらいいのかな。それこそ「フォルダ」とか、「ドライブ」とか、「ファイル」とかいう、データを管理するためのもろもろのアレ。そういう概念を「FileSystemObject」オブジェクトっていうんだと思っている。

当然、Excelにはそんなデータ型は存在しないから、Object型のオブジェクト変数にしとるわけだ。

んで、次。

リスト１の(2)

For Each objSubFolder _
            In CreateObject("Scripting.FileSystemObject") _
              .GetFolder(basePath).SubFolders
Next

１行がやたら長くなるので行継続文字を使っている。「For」～「SubFolders」までが長～い１行。

よく見かけるのは次のような書き方。

Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
With FSO.GetFolder(basePath)
  For Each objSubFolder In .SubFolders
End With

まあ、単にまずFileSystemObjectオブジェクト自体をインスタンス化して変数にセットしてから使っているだけ。FileSystemObjectオブジェクトを後ほど使い回す必要があるんなら、変数にセットした方が使い勝手が良い、というだけだと思う。

とにかく、

CreateObject("Scripting.FileSystemObject").GetFolder(basePath).SubFolders

の部分の処理の順番としては、

1. FileSystemObjectオブジェクトをインスタンス化
2. GetFolderメソッドに、引数（この場合は「basePath」というフォルダパス）を渡して、そのフォルダパスが指し示すFolderオブジェクト（要するに「フォルダ」そのもの）を取得（参考１・参考２）
3. SubFoldersプロパティで「2.」で取得したフォルダ内の全てのサブフォルダをコレクションとして取得（参考）

ということだな（間違ってたら教えてくれください）。

これをFor Each ～ Nextで回すわけだから、要するに、

引数basePathが指すフォルダ内のサブフォルダを一つづつ変数objSubFolderにセットして処理を繰り返す

ことになる。

リスト１の(3)

ここが最大のポイント。メソッドが自分自身を呼び出す。これが「再帰呼び出し」ですね。英文法で自分自身を指し示す「myself」のことを「再帰代名詞」と呼ぶのと同じ。斉木しげるとは関係ない。

Call writeAllFolderPath(objSubFolder.Path)

変数objSubFolderには既にFolderオブジェクトが入っているわけだが、そのFolderオブジェクトのPathプロパティ（要するにフォルダのフルパスね）を引数としてwriteAllFolderPathメソッドを呼ぶ。

そうすると、今objSubFolderに入っているフォルダのさらにサブフォルダをコレクションとして取得して……となるわけ。

これ読んで、処理の流れを頭の中だけで理解できる人いるのかな？？？

というわけで、ちょっと寄り道して処理の流れを見ていこう。

その前にリスト１の(4)の処理だけ見ておく。

リスト１の(4)

objRow = objSh.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
objSh.Range("A" & objRow).Value = objSubFolder.Path

これは簡単。単に、シートのＡ列書き込み済み最終行の次の行番号を取得して、そこに変数objSubFolderに格納されているフォルダのフルパスを書き込んでいるだけ。ちょっとくどいかも知れんけど、

CreateObject("Scripting.FileSystemObject").GetFolder(basePath).SubFolders

で取得したサブフォルダのフルパスをその都度シートのＡ列に書き込んで追加しているだけだ。

再帰呼び出しの挙動

例として、次のような構成のフォルダを作る。

要するに、次のようなフォルダ構成。

実行

ループに突入した直後のobjSubFolderの中身は、

この通り、「フォルダB」。で、「フォルダB」のフルパスを渡してwriteAllFolderPathを呼び出すと、

当然objSubFolderの中身は「フォルダC」。んで、さらに「フォルダC」のフルパスを渡してwriteAllFolderPathを呼び出すと、

今度はもうサブフォルダがないからobjSubFolderはNothingになる。

この段階でやっとここに処理が移る。

シートにフォルダのフルパスが書き込まれた。で、次のループ。

「フォルダB」配下のSubFolderコレクションのうち、「フォルダC」の処理が終わったので、次の「フォルダD」がobjSubFolderに格納されているのが分かる。

実行結果

全てのフォルダパスが書き出された。

おわりに

なんだか、頭がこんがらがってくるんだけど、ステップ実行しながら挙動を確認したら理解はできると思う。

このメソッドを用いて、フォルダ構成をまるごと別のフォルダにコピーするマクロを完成させていく。

新年度を迎えて、自分の担当業務用のフォルダを丸ごと移したい。だけど、中のファイルはいらない

というときに役に立つと思う。

@akashi_keirin on Twitter