キャリア別でシートを作成
いつもの、なんちゃって個人情報。
こちらで、キャリア別にシートを作成したくなったとする。
そこで、先日から改修している↓に手を加えてみた。
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
結果、キャリアごとに4つのシートが作成された。
これは、意外と使えるかも。
参考まで。