今日を乗り切るExcel研究所

Excel に働かされていませんか

【VBA】条件を満たす行のみセル内容を一括変更したい【100本ノック】

今更ながらエクセルの神髄さんのTwitter企画 「VBA100本ノック」への便乗記事、6本目の課題です。

お題:VBA100本ノック 6本目:セルに計算式

方針

データが特定の条件を満たす行でのみ計算列のセルに指定の数式を設定する課題です。

金額に設定する計算式は行内のセル(価格、点数)を参照しますが、相対アドレスで指定するので、結局全ての対象行で同一の数式になります。

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

関連記事

www.shegolab.jp