キャリア別でシートを作成
いつもの、なんちゃって個人情報。
こちらで、キャリア別にシートを作成したくなったとする。
そこで、先日から改修している↓に手を加えてみた。
infoment.hatenablog.com
今回も手を加えたのは、RowFilter関数。元々は指定ワードを含むレコードを残すか、または消すかの選択を行っていた。
そこで今回は、残すかまたは消した結果、或いはその逆で、元の配列を更新する引数を追加してみた（賛否両論ありそう）。
' 編集前の配列。 Public source_array As Variant ' ----------------↓今回追加↓---------------- ' source_arrayの更新 Enum UpdateSource usNone ' 更新しない usResult ' 編集した結果でsource_arrayを更新 usInvers ' 編集した結果の残りで更新 End Enum
' 行のフィルター抽出 ' 初期設定：① 完全一致，②ヘッダーを含めない，③指定文字を消す Public Function RowFilter(filt As Variant, _ column_index As Long, _ Optional rf_LookAt As Excel.XlLookAt = xlWhole, _ Optional rf_header As Excel.XlYesNoGuess = xlYes, _ Optional rf_result As RemainOrDelete = RemainOrDelete.rdDelete, _ Optional rf_source_update As UpdateSource = usNone) ' 仮置用：残す場合。 Dim TempArray_Remain As Variant ReDim TempArray_Remain(rMin To rMax, cMin To cMax) ' 仮置用：消す場合。 Dim TempArray_Delete As Variant ReDim TempArray_Delete(rMin To rMax, cMin To cMax) ' 一行目をヘッダーと見なす場合(xlYes）、強制的に配列の一行目に組み込む。 Dim StartRowIndex As Long If rf_header = xlYes Then For C = cMin To cMax TempArray_Remain(rMin, C) = source_array(rMin, C) TempArray_Delete(rMin, C) = source_array(rMin, C) Next StartRowIndex = rMin + 1 Else StartRowIndex = rMin End If Dim arr As Variant If IsArray(filt) Then arr = filt Else arr = Array(filt) End If ' フィルター。 Dim iR As Long Dim iD As Long iR = StartRowIndex iD = StartRowIndex Dim LoopIndex As Variant Dim LoopFlag As Boolean For r = StartRowIndex To rMax LoopFlag = False For Each LoopIndex In arr ' 部分一致と完全一致の確認。 If rf_LookAt = xlPart Then LoopIndex = "*" & LoopIndex & "*" End If ' 残した結果の配列。 If source_array(r, column_index) Like LoopIndex Then For C = cMin To cMax TempArray_Remain(iR, C) = source_array(r, C) Next iR = iR + 1 LoopFlag = True Exit For End If Next ' 消す結果の配列。 If LoopFlag = False Then For C = cMin To cMax TempArray_Delete(iD, C) = source_array(r, C) Next iD = iD + 1 End If Next ' 消すか残すか、指定された側をセット。 Dim TempArray_Result1 As Variant Dim TempArray_Result2 As Variant Select Case rf_result Case RemainOrDelete.rdDelete TempArray_Result1 = TempArray_Delete i = iD - 1 Case RemainOrDelete.rdRemain TempArray_Result1 = TempArray_Remain i = iR - 1 End Select ' 末尾にあまった空白を消すために、ピッタリサイズの配列へ転記。 ReDim TempArray_Result2(rMin To i, cMin To cMax) For r = rMin To i For C = cMin To cMax TempArray_Result2(r, C) = TempArray_Result1(r, C) Next Next RowFilter = TempArray_Result2 ' ----------------↓今回追加↓---------------- ' Source_arrayの更新確認。 Select Case rf_source_update ' 更新しない。 Case usNone ' 得られた結果で更新する。 Case usResult source_array = RowFilter ' 得られた結果の逆側で更新する。 ' 例えば戻り値が「消す」なら、source_arrayは「残す」で更新。 Case usInvers Select Case rf_result Case RemainOrDelete.rdDelete TempArray_Result1 = TempArray_Remain i = iR - 1 Case RemainOrDelete.rdRemain TempArray_Result1 = TempArray_Delete i = iD - 1 End Select ReDim TempArray_Result2(rMin To i, cMin To cMax) For r = rMin To i For C = cMin To cMax TempArray_Result2(r, C) = TempArray_Result1(r, C) Next Next source_array = TempArray_Result2 End Select End Function
それでは早速、テストしてみよう。
Sub test() ' 名簿格納用配列。 Dim arr As Variant ' テーブル（なんちゃって個人情報）。 Dim Tb As Excel.ListObject Set Tb = ActiveSheet.ListObjects(1) With New ArrayEdit ' テーブル全体を元となる配列に格納する。 .source_array = Tb.Range ' キャリア別でシートを作成。 Dim キャリア As Variant Dim Sh As Worksheet For Each キャリア In Array("ドコモ", "ソフトバンク", "ツーカー", "au") arr = .RowFilter(filt:=キャリア, _ column_index:=Tb.ListColumns("キャリア").Index, _ rf_result:=rdRemain, _ rf_source_update:=usInvers) Set Sh = Sheets.Add(After:=Sheets(Sheets.Count)) Sh.Name = キャリア Range("A1").Resize(UBound(arr), UBound(arr, 2)) = arr Next End With End Sub
結果、キャリアごとに４つのシートが作成された。
これは、意外と使えるかも。
参考まで。
配列のフィルターで指定日の前、或いは後のみのレコードを残す、または削除する
９ヶ月ほど前に、配列を編集する自作のクラスモジュールを纏めてみた。
infoment.hatenablog.com
その後、業務などで頻繁に使用しているうちに、幾つか修正点が出てきた。
前回に引き続き今回も、その中の一つをご紹介。
前回紹介した「RowFilte」について、職場でこんなコメントが寄せられた。
『6/1より前』みたいな抽出の仕方はできませんか？
実はRowNumericFilter関数というものを別で作成していたのだが、名前が示す通り「Numeric（数値）」に限定していた。このままでは使えない。
ということで、作成者の特権とばかり、対象範囲を日付にまで拡張してみた。
といっても、大したことはしていない。IsNumericで数値判定してNGになる前に、IsDateで評価して拾うだけ。実際は、二値を比較する↓こちらを少しだけ改修。
' 大小比較用 Enum HighOrLow hlMore ' 以上 hlLess ' 以下 hlAbobe ' 超 hlBelow ' 未満 End Enum
Private Function CompareResultValue(ByVal val1 As Variant, _ ByVal val2 As Variant, _ rf_type As HighOrLow, _ rf_result As RemainOrDelete) As Boolean ' 初期値。 CompareResultValue = False ' 数値か否かを確認。 If IsNumeric(val1) = False Or IsNumeric(val2) = False Then ' -----------------↓今回追加↓----------------- ' 日付か否かを確認。 If IsDate(val1) = False Or IsDate(val2) = False Then Exit Function End If ' -----------------↑今回追加↑----------------- End If ' 大小比較。 Select Case rf_result ' 残す場合。 Case RemainOrDelete.rdRemain Select Case rf_type ' 以上の場合。 Case HighOrLow.hlMore If val1 >= val2 Then CompareResultValue = True ' 超える場合。 Case HighOrLow.hlAbobe If val1 > val2 Then CompareResultValue = True ' 以下の場合。 Case HighOrLow.hlLess If val1 <= val2 Then CompareResultValue = True ' 未満の場合。 Case HighOrLow.hlBelow If val1 < val2 Then CompareResultValue = True End Select ' 消す場合。※残す場合と逆の条件になる。 Case RemainOrDelete.rdDelete Select Case rf_type ' 以上の場合。 Case HighOrLow.hlMore If val1 < val2 Then CompareResultValue = True ' 超える場合。 Case HighOrLow.hlAbobe If val1 <= val2 Then CompareResultValue = True ' 以下の場合。 Case HighOrLow.hlLess If val1 > val2 Then CompareResultValue = True ' 未満の場合。 Case HighOrLow.hlBelow If val1 >= val2 Then CompareResultValue = True End Select End Select End Function
それでは、毎度の「なんちゃって個人情報」で今回も確認してみよう。
Sub test() ' 名簿格納用配列。 Dim arr As Variant ' テーブル（なんちゃって個人情報）。 Dim Tb As Excel.ListObject Set Tb = ActiveSheet.ListObjects(1) With New ArrayEdit ' テーブル全体を、元となる配列に格納する。 .source_array = Tb.Range ' 誕生日が１９７０年１月１日以降のデータのみ抽出する。 arr = .RowNumericFilter(filt:=CDate("1970/1/1"), _ column_index:=Tb.ListColumns("誕生日").Index, _ rf_type:=hlMore, _ rf_header:=xlYes, _ rf_result:=rdRemain) ' 抽出後の配列を、新たに作成したシート「テスト」のA1に貼り付けてテーブル化。 .source_array = arr .PasteArray "A1", "テスト", , , ptTable, True End With End Sub
結果、指定日以降の誕生日のみに絞り込むことが出来た。
前回同様、少なくとも個人的には、用途の幅が広がりそうです。
参考まで。
配列のフィルターで複数の文字列指定
９ヶ月ほど前に、配列を編集する自作のクラスモジュールを纏めてみた。
infoment.hatenablog.com
その後、業務などで頻繁に使用しているうちに、幾つか修正点が出てきた。
今回は、その中の一つをご紹介。
クラスモジュールで、行のフィルター抽出を行うユーザー定義関数を作成した。
' 行のフィルター抽出 ' 初期設定：① 完全一致，②ヘッダーを含めない，③指定文字を消す Public Function RowFilter(filt As Variant, _ column_index As Long, _ Optional rf_LookAt As Excel.XlLookAt = xlWhole, _ Optional rf_header As Excel.XlYesNoGuess = xlYes, _ Optional rf_result As RemainOrDelete = RemainOrDelete.rdDelete) ' 仮置用：残す場合。 Dim TempArray_Remain As Variant ReDim TempArray_Remain(rMin To rMax, cMin To cMax) ' 仮置用：消す場合。 Dim TempArray_Delete As Variant ReDim TempArray_Delete(rMin To rMax, cMin To cMax) ' 一行目をヘッダーと見なす場合(xlYes）、強制的に配列の一行目に組み込む。 Dim StartRowIndex As Long If rf_header = xlYes Then For c = cMin To cMax TempArray_Remain(rMin, c) = source_array(rMin, c) TempArray_Delete(rMin, c) = source_array(rMin, c) Next StartRowIndex = rMin + 1 Else StartRowIndex = rMin End If ' 部分一致と完全一致の確認。 If rf_LookAt = xlPart Then filt = "*" & filt & "*" End If ' フィルター。 Dim iR As Long Dim iD As Long iR = StartRowIndex iD = StartRowIndex For r = StartRowIndex To rMax ' 消した結果の配列。 If Not source_array(r, column_index) Like filt Then For c = cMin To cMax TempArray_Delete(iD, c) = source_array(r, c) Next iD = iD + 1 ' 残した結果の配列。 Else For c = cMin To cMax TempArray_Remain(iR, c) = source_array(r, c) Next iR = iR + 1 End If Next ' 消すか残すか、指定された側をセット。 Dim TempArray_Result1 As Variant Dim TempArray_Result2 As Variant Select Case rf_result Case RemainOrDelete.rdDelete TempArray_Result1 = TempArray_Delete i = iD - 1 Case RemainOrDelete.rdRemain TempArray_Result1 = TempArray_Remain i = iR - 1 End Select ' 末尾にあまった空白を消すために、ピッタリサイズの配列へ転記。 ReDim TempArray_Result2(rMin To i, cMin To cMax) For r = rMin To i For c = cMin To cMax TempArray_Result2(r, c) = TempArray_Result1(r, c) Next Next RowFilter = TempArray_Result2 End Function
これにより二次元配列の指定列について、指定した文字を含む行を消すか、または残した結果を新たな配列として受け取ることが出来る。
ところが使用する内に、複数のキーワードで同時に評価したい場面が多々登場するようになった。
そこで引数filtが配列でも機能するよう作り替えてみた。
' 行のフィルター抽出 ' 初期設定：① 完全一致，②ヘッダーを含めない，③指定文字を消す Public Function RowFilter(filt As Variant, _ column_index As Long, _ Optional rf_LookAt As Excel.XlLookAt = xlWhole, _ Optional rf_header As Excel.XlYesNoGuess = xlYes, _ Optional rf_result As RemainOrDelete = RemainOrDelete.rdDelete) ' 仮置用：残す場合。 Dim TempArray_Remain As Variant ReDim TempArray_Remain(rMin To rMax, cMin To cMax) ' 仮置用：消す場合。 Dim TempArray_Delete As Variant ReDim TempArray_Delete(rMin To rMax, cMin To cMax) ' 一行目をヘッダーと見なす場合(xlYes）、強制的に配列の一行目に組み込む。 Dim StartRowIndex As Long If rf_header = xlYes Then For C = cMin To cMax TempArray_Remain(rMin, C) = source_array(rMin, C) TempArray_Delete(rMin, C) = source_array(rMin, C) Next StartRowIndex = rMin + 1 Else StartRowIndex = rMin End If Dim arr As Variant If IsArray(filt) Then arr = filt Else arr = Array(filt) End If ' フィルター。 Dim iR As Long Dim iD As Long iR = StartRowIndex iD = StartRowIndex Dim LoopIndex As Variant Dim LoopFlag As Boolean For r = StartRowIndex To rMax LoopFlag = False For Each LoopIndex In arr ' 部分一致と完全一致の確認。 If rf_LookAt = xlPart Then LoopIndex = "*" & LoopIndex & "*" End If ' 残した結果の配列。 If source_array(r, column_index) Like LoopIndex Then For C = cMin To cMax TempArray_Remain(iR, C) = source_array(r, C) Next iR = iR + 1 LoopFlag = True Exit For End If Next ' 消す結果の配列。 If LoopFlag = False Then For C = cMin To cMax TempArray_Delete(iD, C) = source_array(r, C) Next iD = iD + 1 End If Next ' 消すか残すか、指定された側をセット。 Dim TempArray_Result1 As Variant Dim TempArray_Result2 As Variant Select Case rf_result Case RemainOrDelete.rdDelete TempArray_Result1 = TempArray_Delete i = iD - 1 Case RemainOrDelete.rdRemain TempArray_Result1 = TempArray_Remain i = iR - 1 End Select ' 末尾にあまった空白を消すために、ピッタリサイズの配列へ転記。 ReDim TempArray_Result2(rMin To i, cMin To cMax) For r = rMin To i For C = cMin To cMax TempArray_Result2(r, C) = TempArray_Result1(r, C) Next Next RowFilter = TempArray_Result2 End Function
引数filtが文字列・配列のどちらでも対応できるよう、文字列の場合も強制的に、要素が一つの配列とした。
Dim arr As Variant If IsArray(filt) Then arr = filt Else arr = Array(filt) End If
ちなみにこの部分には、この日の内容が活かされている。
infoment.hatenablog.com
複数のキーワードのうちどれかに一致したら、ループから抜けなければならない。しかし、抜けすぎてはいけない。その確認の結果が、この内容に繋がっている。
infoment.hatenablog.com
部分一致の場合、キーワードの前後にワイルドカードを付して、Like演算子で評価している。しかしもし、引数に与えた時点でワイルドカードが含まれていたら複数のそれが連続で登場することになるが、問題ないか。その確認の結果が、この日の内容に繋がった。
infoment.hatenablog.com
それでは、いつもの「なんちゃって個人情報」で試してみよう。
例えば都道府県について、「山*県」と「福*県」のみのレコードに絞り込みたい。先ほどのクラスを用いると、こうなる。
Sub FilterTest() Dim arr As Variant With New VBAProject.ArrayEdit ' 元の値を配列にセット。 .source_array = ActiveSheet.UsedRange ' 都道府県の列（９列目）から、「山*県」と「福*県」を抽出。 arr = .RowFilter(filt:=Array("山*県", "福*県"), _ column_index:=9, _ rf_LookAt:=xlWhole, _ rf_header:=xlYes, _ rf_result:=rdRemain) ' 抽出後の配列を、新たなシート「確認」を作成して貼り付けてテーブル化。 .source_array = arr Dim Tb As ListObject Set Tb = .PasteArray("A1", "確認", , , ptTable, True) End With End Sub
結果がこちら。
少なくとも個人的には、用途の幅が広がりそうです。
参考まで。
配列になってなかった（失敗談）
今回は、配列にまつわる失敗談。
例えば、こんな名簿があるとする。
この「名前」の部分を一旦配列に格納して、処理したいと考えた。
Sub Test() ' テーブルを変数に格納。 Dim Tb As Excel.ListObject Set Tb = ActiveSheet.ListObjects(1) ' 名前の列を配列に格納。 Dim arr As Variant arr = Tb.ListColumns("名前").DataBodyRange ' 繰り返し処理で配列の中身をイミディエイトウィンドウに表示。 Dim person As Variant For Each person In arr Debug.Print person Next End Sub
For Eachで繰り返し処理しているので、テーブルの行数は不問となる。
ところが、色々とテストしていると、エラーになるパターンがあった。
どういう場合かというと、それは、レコードが一行しかないとき。
変数をVariantで宣言していたため、レコードが一行しかない場合、arrはString型の変数として振舞ってしまった（？）ようだ。
配列ではないため、ループさせようとした結果、エラーとなった。
そこで、今回採った解決策がコチラ。
Sub Test() ' テーブルを変数に格納。 Dim Tb As Excel.ListObject Set Tb = ActiveSheet.ListObjects(1) ' 名前の列を配列に格納。 Dim arr As Variant arr = Tb.ListColumns("名前").DataBodyRange ' 文字列の場合、要素が１個だけの配列に変換。 If IsArray(arr) = False Then arr = Array(arr) End If ' 繰り返し処理で配列の中身をイミディエイトウィンドウに表示。 Dim person As Variant For Each person In arr Debug.Print person Next End Sub
配列でなかった場合は、強引に配列化している。
でもきっと、もっとスマートな方法があるに違いない。です。
参考まで。
ワイルドカードは何個あってもいい？（Like演算子）
ふと、思った。ワイルドカードって、複数あっても良いのか？
例えばLike演算子を使って、こんな評価をしてみる。
結果は、「True」。つまり、「り」と「ご」で挟んだ何某かの文字「*」を
「り*ご」とするならば、「りんご」はこれと似ているという訳だ。
ちなみに「*」は、「り」と「ご」で挟まれる文字数が幾つでも良い。
一方で「?」は、一文字限定なので、この場合は「似ていない」となる。
そして今回疑問に思ったのは、「*」は複数連なっても問題ないか？というもの。
早速実験してみよう。
結果は、↓のとおり。
どうやら、「*********」が結果として「ん」の一文字だけだったとしても問題ないようだ。まあ、間に何もなくてもＯＫなのだから、当たり前と言えば当たり前か。
参考まで。
多重ループからの脱出
たまに、多重ループから抜けたいとき、「どうだっけ？」と迷うことがある。
例えば、こんなとき。
Sub Test() Dim i As Variant Dim j As Variant For Each i In Array(1, 2, 3) For Each j In Array("一", "二", "三") If j = "三" Then Exit For Else Debug.Print i & j End If Next Next End Sub
j が「三」ならループを抜けるわけだが、果たして外側のループまで抜けてしまうのか。結果は以下のとおり、抜けるのはあくまで内側のループだけ。
もし外側まで抜けていたなら、このような結果になる。
ちなみに、一気に外側まで抜ける方法は、私の知る限り三つ。
１．ラベル行まで一気に抜ける
以下の例では、多重ループの外にラベル行（Continue：）へ処理を移動。
Sub Test() Dim i As Variant Dim j As Variant For Each i In Array(1, 2, 3) For Each j In Array("一", "二", "三") If j = "三" Then GoTo Continue: Else Debug.Print i & j End If Next Next Continue: End Sub
たまにお見掛けするが、個人的には殆ど使用したことが無い（好みの問題）。
２．フラグを使用
内側のループを抜ける際にフラグを立て、更にフラグが立って（＝True）いれば、外側のループを抜ける。
Sub Test() Dim i As Variant Dim j As Variant Dim Flag As Boolean For Each i In Array(1, 2, 3) For Each j In Array("一", "二", "三") If j = "三" Then Flag = True Exit For Else Debug.Print i & j End If Next If Flag Then Exit For Next End Sub
どちらかと言えば、先の例よりこちらを使う場合が多い。ただし、変数が一つ増えるのが難点。
３．プロシージャ自体を終了
その場で処理を終えて良い場合のみ使用可能なため、用法としては限定的。
Sub Test() Dim i As Variant Dim j As Variant For Each i In Array(1, 2, 3) For Each j In Array("一", "二", "三") If j = "三" Then Exit Sub Else Debug.Print i & j End If Next Next End Sub
終わりに
個人的に常用するのは、二重ループまでかな。内側のループをユーザー定義関数化するなどして、三重ループ以上は極力避けたいところ。
なぜなら、そうでないと、私の頭では理解が追い付かなくなるので。
参考まで。
小計と合計（SUBTOTAL関数）
今日は職場で、小計と合計を求める、とても便利な方法を教わった。
割とよく、こんな表を見かける。
小計と合計に設定された数式を見てみると、こんな感じだ。
「合計」の部分は、小計を一つずつ選択しながら足している。二つぐらいなら我慢できるが、５つも６つも登場すると辟易してしまう。
本当は、上から下までズババンと範囲指定して足し算できれば簡単だ。
しかし「小計」の部分まで足し算されて、合計金額が倍になるため、そのままではＮＧだ。
そして今日、上記問題の解決策として、このSUM関数をSUBTOTAL関数に置き換える方法を教わった。
SUBTOTAL関数の一つ目の引数は、集計方法を表している。今回は足し算なので、「9」を選択する。二つ目の引数は、足し算する範囲を指定する。
すると、こうなった。
御覧のとおり上から下まで一括で範囲選択しても、SUBTOTALで求めた小計は加算されていない。
どうやらSUBTOTAL関数は、同じSUBTOTAL関数で求めた合計を加算しないらしい。昔からこの関数の存在は知っていたのに、そんな特徴があるとは知らなかった。
ということで、今日のはホント、お勧めです。
参考まで。
