トップ　>　玄人向け　>　VBA高速化検証：セルの塗りつぶし

VBA高速化検証：セルの塗りつぶし　　　2010.07.19

ソフト作成の過程で、VBAの処理スピードに関する検証を行いました。
今回は『選択範囲内の該当データセルを塗りつぶす』というケースで、一般に使われているであろう方法から、そうでない方法まで、6つの方法の検証テストを行いました。

【サービス紹介】Excel マクロ 高速化サービス　特典あり

スピード検証テスト

下の表とグラフは、私のパソコン※でスピード検証テストを行った結果です。
※Vista / intel Core2 Duo / Excel2003


結果を見て分かる通り、Test_6のケースが断トツに速いことが分かります。
セル20万個、内、色を塗りつぶす該当データセル10万個でも、1秒未満です。
では、Test_1～6の詳細コードを紹介していきます。

Test_1

テスト1は、選択範囲のセルを塗りつぶす場合に、一般的に使うであろうコードです。
For Each ～ Next とRange変数を使用し、Selection内を検索します。Range変数の値を調べ、値が該当すればそのセルを黄色に塗りつぶします。 

Sub Test_1()
    Dim objRange As Range
    Application.ScreenUpdating = False
    For Each objRange In Selection
        If objRange.Value = 1 Then objRange.Interior.ColorIndex = 6
    Next
    Application.ScreenUpdating = True
End Sub

コードが短く可読性が高いといった特徴はありますが、選択範囲・該当データ量が多い場合は時間がかかります。

Test_2

テスト2ではバリアント変数を使用します。※選択範囲が単一セルの場合はエラーになります。

バリアント変数に選択範囲の値を代入し、バリアント変数内を調べます。該当データがあった場合は、選択範囲の行数から、該当セルの行・列を割り出し塗りつぶします。 

Sub Test_2()
    Dim lngRow As Long
    Dim lngCol As Long
    Dim lngIndex As Long
    Dim lngRowsC As Long
    Dim varI As Variant
    Dim varData() As Variant
    Application.ScreenUpdating = False
    lngIndex = 0
    With Selection
        lngRowsC = .Rows.Count  '選択範囲の行数
        varData = .Value        '選択範囲の値をバリアント変数に代入
        For Each varI In varData
            lngIndex = lngIndex + 1
            If varI = 1 Then
                '選択範囲の行数を基に選択範囲内での該当セルの行・列を計算
                lngRow = ((lngIndex - 1) Mod lngRowsC) + 1
                lngCol = (lngIndex + lngRowsC - 1) \ lngRowsC
                '該当セルを塗りつぶす
                .Cells(lngRow, lngCol).Interior.ColorIndex = 6
            End If
        Next
    End With
    Application.ScreenUpdating = True
End Sub

テスト1と比較すると、処理時間は約7%短縮されています。

Test_3

テスト3はテスト2の変形版で、For Each ～ Next　を　For ～ Next (×2)　にしています。
※選択範囲が単一セルの場合はエラーになります。 

Sub Test_3()
    Dim lngRow As Long
    Dim lngCol As Long
    Dim lngRowsC As Long
    Dim lngColsC As Long
    Dim varData() As Variant
    Application.ScreenUpdating = False
    With Selection
        lngRowsC = .Rows.Count
        lngColsC = .Columns.Count
        varData = .Value
        For lngRow = 1 To lngRowsC
            For lngCol = 1 To lngColsC
                If varData(lngRow, lngCol) = 1 Then .Cells(lngRow, lngCol).Interior.ColorIndex = 6
            Next
        Next
    End With
    Application.ScreenUpdating = True
End Sub

テスト2と比較すると若干速めですが、セル20万個の場合でも、違いは0.04秒未満なので、体感速度は変わらないといって良いでしょう。

Test_4

テスト4はテスト2の変形版です。テスト2との違いはセルのアドレスを取得し、使用している点です。
※選択範囲が単一セルの場合はエラーになります。

選択範囲の値をバリアント変数に代入し、バリアント変数内を調べる。該当データがあった場合、選択範囲内の該当セルの行・列を割り出し、それを基に該当セルのアドレスをA1形式で取得する。Rangeオブジェクトにそのアドレスを指定し、セルを黄色に塗りつぶす。 

Sub Test_4()
    Dim lngRow As Long
    Dim lngCol As Long
    Dim lngIndex As Long
    Dim lngRowsC As Long
    Dim strAddress As String
    Dim varI As Variant
    Dim varData() As Variant
    Application.ScreenUpdating = False
    lngIndex = 0
    strAddress = vbNullString
    With Selection
        lngRowsC = .Rows.Count
        varData = .Value
        For Each varI In varData
            lngIndex = lngIndex + 1
            If varI = 1 Then
                lngRow = ((lngIndex - 1) Mod lngRowsC) + 1
                lngCol = (lngIndex + lngRowsC - 1) \ lngRowsC
                'セルのアドレスをA1形式で取得
                strAddress = .Cells(lngRow, lngCol).Address(False, False)
                ActiveSheet.Range(strAddress).Interior.ColorIndex = 6
            End If
        Next
    End With
    Application.ScreenUpdating = True
End Sub

テスト1に比較すると、処理時間は約22%長くなっています。

Test_5

テスト5はテスト4の変形版です。これまでのテストに比べ時間はかなり短縮されています。
※選択範囲が単一セルの場合はエラーになります。

テスト4との違いは、複数のセルをまとめて塗りつぶしている事です。取得したセルのアドレスを複数個つなげ、Rangeオブジェクトにまとめて指定する方法を用いています。
Rangeオブジェクトに指定できるのは255文字までのようなので、つなげたアドレスの文字数が255を超える直前に、色を塗りつぶす処理を行っています。 

Sub Test_5()
    Dim lngRow As Long
    Dim lngCol As Long
    Dim lngRowsC As Long
    Dim lngIndex As Long
    Dim strAddress As String
    Dim strAddressSec As String
    Dim varI As Variant
    Dim varData() As Variant
    Const conC As String = ","
    Application.ScreenUpdating = False
    lngIndex = 0
    strAddress = vbNullString
    strAddressSec = vbNullString
    With Selection
        lngRowsC = .Rows.Count
        varData = .Value
        For Each varI In varData
            lngIndex = lngIndex + 1
            If varI = 1 Then
                lngRow = ((lngIndex - 1) Mod lngRowsC) + 1
                lngCol = (lngIndex + lngRowsC - 1) \ lngRowsC
                strAddressSec = conC & .Cells(lngRow, lngCol).Address(False, False)
                If 255 < Len(strAddress) + Len(strAddressSec) Then
                    GoSub JoinString
                Else
                    strAddress = strAddress & strAddressSec
                End If
            End If
        Next
        If 0 < Len(strAddress) Then GoSub JoinString
    End With
    Application.ScreenUpdating = True
Exit Sub
JoinString:
    strAddress = Mid$(strAddress, 2)
    ActiveSheet.Range(strAddress).Interior.ColorIndex = 6
    strAddress = strAddressSec
    Return
End Sub

テスト1と比較すると、処理時間は約72%短縮されています。ただ、可読性の点では難ありです。

Test_6

テスト6は今回の検証では最速でした。※選択範囲が単一セルの場合はエラーになります。

テスト6は、該当セルのアドレスをR1C1参照形式で書き、それをApplication.ConvertFormulaメソッドでA1形式に変換してセルを塗りつぶしています。Application.ConvertFormulaメソッドに指定できるのは255文字までのようなので、255文字を超える直前に変換と色を塗る処理を行っています。 

Sub Test_6()
    Dim lngI As Long
    Dim lngRow As Long
    Dim lngCol As Long
    Dim lngRowsC As Long
    Dim lngColsC As Long
    Dim lngIndex As Long
    Dim lngSelCellsR As Long
    Dim lngSelCellsC As Long
    Dim strAddress As String
    Dim strAddressSec As String
    Dim varI As Variant
    Dim varData() As Variant
    Const conC As String = ","
    Const conRow As String = ",R"
    Const conCol As String = "C"
    lngIndex = 0
    strAddress = vbNullString
    Application.ScreenUpdating = False
    With Selection
        lngRowsC = .Rows.Count
        varData = .Value
        '選択範囲の左上アドレスをR1C1で取得
        strAddress = .Cells(1, 1).Address(ReferenceStyle:=xlR1C1)
        strAddress = Mid$(strAddress, 2)
        lngI = InStr(1, strAddress, conCol, vbTextCompare)      '[C]の位置を取得
        lngSelCellsR = CLng(Left$(strAddress, lngI - 1)) - 1    '行を取り出し
        lngSelCellsC = CLng(Mid$(strAddress, lngI + 1)) - 1     '列を取り出し
        strAddress = vbNullString
        strAddressSec = vbNullString
        For Each varI In varData
            lngIndex = lngIndex + 1
            If varI = 1 Then
                'シート上での行番号
                lngRow = ((lngIndex - 1) Mod lngRowsC) + 1 + lngSelCellsR
                'シート上での列番号
                lngCol = (lngIndex + lngRowsC - 1) \ lngRowsC + lngSelCellsC
                'R1C1参照として書き出し
                strAddressSec = conRow & lngRow & conCol & lngCol
                If 255 < Len(strAddress) + Len(strAddressSec) Then
                    GoSub JoinAddress
                Else
                    strAddress = strAddress & strAddressSec
                End If
            End If
        Next
        If 0 < Len(strAddress) Then GoSub JoinAddress
    End With
    Application.ScreenUpdating = True
Exit Sub
JoinAddress:
    strAddress = Mid$(strAddress, 2)
    strAddress = Application.ConvertFormula(strAddress, xlR1C1, xlA1, xlRelative)
    ActiveSheet.Range(strAddress).Interior.ColorIndex = 6
    strAddress = strAddressSec
    Return
End Sub

テスト1と比較すると、処理時間は約81%短縮されています。ただ、可読性が低く分かりづらいコードです。

補足：「選択範囲が単一セルのケースの対応例」

上記Test_2～6のコードのように、選択範囲をバリアント変数に代入し、For Each ～ Next を使用する場合、選択範囲が単一セルの場合はエラーになります。その様なケースを回避する例を下に記します。Test_2のコードを改編します。 

Sub Test_X()
    Dim lngRow As Long
    Dim lngCol As Long
    Dim lngIndex As Long
    Dim lngRowsC As Long
    Dim varI As Variant
    Dim varData() As Variant
    With Application
        .ScreenUpdating = False
        lngIndex = 0
        With .Selection
            lngRowsC = .Rows.Count  '選択範囲の行数
            If .Cells.Count = 1 Then
                ReDim varData(1 To 1, 1 To 1)
                varData(1, 1) = .Value
            Else
                varData = .Value
            End If
            For Each varI In varData
                lngIndex = lngIndex + 1
                If varI = 1 Then
                    '選択範囲の行数を基に選択範囲内での該当セルの行・列を計算
                    lngRow = ((lngIndex - 1) Mod lngRowsC) + 1
                    lngCol = (lngIndex + lngRowsC - 1) \ lngRowsC
                    '該当セルを塗りつぶす
                    .Cells(lngRow, lngCol).Interior.ColorIndex = 6
                End If
            Next
        End With
        .ScreenUpdating = True
    End With
End Sub

検証から思うこと

今回の検証は、選択範囲の該当データセルに色を付けるといった限られたケースでした。しかし、
・選択範囲の値をバリアント変数に代入する。
・セルアドレスを繋げRangeオブジェクトに指定する事で、一度に複数のセルのプロパティを設定する。
・位置計算を行い、R1C1参照を書く事でスピードアップを図る。
・R1C1参照を繋げて、一度にA1形式に変換し使用する。

といったことは、他の状況でも応用できるのではないかと思います。今回の検証が皆様に活かされれば幸いです。

※今回のテストは私のパソコンのみの検証であり、どのような環境でも、スピードが向上する事を保証するものではありません。
※選択範囲内の該当データ個数の割合で検証テストの結果に違いが出る事が考えられます。
※他言語のExcelでは、パスセパレータやR1C1参照形式が異なることがありますので、上記コード（特にTest_6）はエラーになる可能性が高いです。

検証テストコードとファイル

●検証テストコード　[[Code]]
●Excel97-2010　[Test_File]　検証テストを行ったファイルです。

前の記事：「ScreenUpdatingプロパティ」　最初の記事：「変数の型の違い」

ページトップへ戻る
Copyright(C) 2009- 坂江 保 All Rights Reserved.