今更ながらエクセルの神髄さんのTwitter企画 「VBA100本ノック」への便乗記事、6本目の課題です。
お題：VBA100本ノック 6本目：セルに計算式
#VBA100本ノック 6本目
— エクセルの神髄 (@yamaoka_ss) 2020年10月24日
画像のようにA1から始まる表があります。
D列にB列×C列の計算式を入れてください。
ただし商品コードに"-"の枝番が付いている場合は計算式を入れずそのままにしてください。
例.D2にはB2×C2の計算式を入れる。D4:D5には計算式を入れない。 pic.twitter.com/6Q8reO8A39
問題ページ
方針
データが特定の条件を満たす行でのみ計算列のセルに指定の数式を設定する課題です。
金額に設定する計算式は行内のセル（価格、点数）を参照しますが、相対アドレスで指定するので、結局全ての対象行で同一の数式になります。
Excel でやるなら、「フィルター」や「フィルターオプション」で該当行を絞り込みして範囲選択後一括入力するところでしょう。
絞り込みしたデータ範囲に対して範囲選択で色を変えたり値を入力しても、間にある非表示（不可視）の行データには影響しません。
それは VBA でも同じはずです。
解答
Option Explicit Private Enum 明細 商品コード = 1 単価 点数 金額 End Enum Private Const 商品コード_枝番なし = "<>*-*" Sub VBA100_006() Dim table As Range Set table = ActiveSheet.Range("A1").CurrentRegion If table.Cells.Count = 1 Then Beep: Exit Sub Dim data As Range Set data = Intersect(table, table.Offset(1)) Dim r As Range Set r = data.Rows(1).Cells Dim calc As String calc = formatA1("=@*@", r(明細.単価), r(明細.点数)) ' ="=B2*C2" Application.ScreenUpdating = False data.Columns(明細.金額).ClearContents ' 絞り込み table.AutoFilter Field:=明細.商品コード, Criteria1:=商品コード_枝番なし If 1 < countVisibleRows(table) Then ' 見出し行以外にも可視行がある場合 data.Columns(明細.金額).formula = calc ' データの可視行にのみ数式を一括で設定する End If table.AutoFilter Application.ScreenUpdating = True End Sub ' Rangeの可視行行数を返す Private Function countVisibleRows(rng As Range) As Long On Error Resume Next countVisibleRows = rng.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count End Function ' "@"をRengeのA1形式の相対アドレスに置き換える Private Function formatA1(ByVal tmpl As String, ParamArray rngs() As Variant) As String Dim rng As Variant For Each rng In rngs tmpl = Replace(tmpl, "@", rng.Address(False, False), 1, 1) Next formatA1 = tmpl End Function
#考察
AutoFilter （フィルター）や AdvancedFilter （フィルターオプション）で絞り込まれている Range に対して、値や数式を設定すると、 シート上で可視となっている行のセル範囲にのみ反映され、不可視となっているセル範囲では何も変更されません。
つまりフィルターによって Range の操作対象とする部分範囲を選択（Select）できるのです。
これを利用すると、特定の条件で選択したデータ行に対してセルの値や数式の一括変更が可能です。
ちなみに同じ不可視でも、行の「非表示」設定や「グループ化」による不可視を含むセル範囲では、このような選択はおきません。
AutoFilter と AdvancedFilter のどちらを使ってもいいのですが、一長一短があります。
AutoFilter を使う
上記解答例は AutoFilter メソッドを使ったものです。
AutoFilter メソッドはお手軽ですが、基本的に単純な値の比較による絞り込みしかできず、複雑な条件、例えば 複数の列を参照して値を比較するような条件での行選択は難しいです。
table.AutoFilter Field:=1, Criteria1:="東京" ' 列1の値が「東京」の行のみを選択 data.Columns(4).Value = 123 ' 選択行の列4の値を一括で「123」に変更 table.AutoFilter ' フィルター解除
一行も選択されなかった、つまり全ての行が不可視となった場合、注意が必要です。
セル範囲の全体が不可視なら、全行で変更なしになりそうですが、なぜか逆に全行の範囲に変更が反映されてしまいます。 そのため、全行が不可視の場合を想定して変更をスキップさせるロジックが必要となります。
また、マクロを実行すると、既存のフィルターの状態を変更してしまうので、元データによってはデータ範囲でもともとフィルターが有効になっているかどうかや Excel テーブルになっていないかに気を遣う必要があるかもしれません。
AdvancedFilter を使う
AdvancedFilter メソッドは高度な条件で行選択が可能ですが、シート上に絞り込み条件を用意する必要があり、そのセル範囲を確保するのが面倒です。
criteria.Cells(1).Value = "都道府県" ' 見出しが「都道府県」の列で criteria.Cells(2).Value = "東京" ' 値が「東京」の行のみを table.AdvancedFilter xlFilterInPlace, criteria ' 絞り込み data.Columns(4).Value = 123 ' 絞り込み結果の列4の値を一括で「123」に変更 sheet.ShowAllData ' フィルター解除
絞り込みの解除は Worksheet.ShowAllData メソッドを使います。
AdvancedFilter メソッドでも、全行が不可視となった状況を判定しなければならないのは AutoFilter と一緒です。
加えて AdvancedFilter では、絞り込みを解除するときに、逆に全行が選択された状況（全行が可視）を回避する必要があります。 そうしないと Worksheet.ShowAllData でエラーになるからです。 もっとも単純に On Error Resume Next でエラーをスルーするだけでもよさそうですが。
AdvancedFilter メソッドについては、以下の記事でも取り上げて解説しているので興味があれば参考にしてください。
最後に AdvancedFilter を使った場合の解答例も掲載しておきます。
Option Explicit Private Enum 明細 商品コード = 1 単価 点数 金額 End Enum Private Const 商品コード_枝番なし = "<>*-*" Sub VBA100_006_ex2() Dim sht As Worksheet Set sht = ActiveSheet Dim table As Range Set table = sht.Range("A1").CurrentRegion If table.Cells.Count = 1 Then Beep: Exit Sub Dim data As Range Set data = Intersect(table, table.Offset(1)) Dim r As Range Set r = data.Rows(1).Cells ' 設定する数式 Dim calc As String calc = formatA1("=@*@", r(明細.単価), r(明細.点数)) ' ="=B2*C2" ' 絞り込み条件 Dim criteria As Range Set criteria = table.Offset(, table.Columns.Count).Range("B1:B2") ' 可視行行数 Dim cnt As Long Application.ScreenUpdating = False criteria.Cells(1).Value = "商品コード" criteria.Cells(2).Value = 商品コード_枝番なし data.Columns(明細.金額).ClearContents table.AdvancedFilter xlFilterInPlace, criteria ' 条件により絞り込み cnt = countVisibleRows(data) If 0 < cnt Then ' 可視行がある場合 data.Columns(明細.金額).FormulaLocal = calc ' 可視行にのみ数式を設定 End If If cnt < data.Rows.Count Then sht.ShowAllData sht.Names("Criteria").Delete criteria.Clear Application.ScreenUpdating = True End Sub ' Rangeの可視行行数を返す Private Function countVisibleRows(rng As Range) As Long On Error Resume Next countVisibleRows = rng.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count End Function ' "@"をRengeのA1形式の相対アドレスに置き換える Private Function formatA1(ByVal tmpl As String, ParamArray rngs() As Variant) As String Dim rng As Variant For Each rng In rngs tmpl = Replace(tmpl, "@", rng.Address(False, False), 1, 1) Next formatA1 = tmpl End Function
