良く使用するセルを探すモジュール | エクセルマクロ(VBA)実践蔵(じっせんぐら)

トップ項目一覧

エクセルでは、データを空白まで読み続けたい場合と、空白を飛ばして、末端までデータを取得したい場合があると思います。ループの終了条件を最終行に設定し、ループ内で空白を飛ばす処理を含めればよいのですが、ループ内の処理が多くなるとコードが見づらくなるため、なるべくモジュール化できるものは、モジュール化して、本当に必要な処理だけのループとすると見やすくなります。

 
'**************************************************** 
' 第一引数のtargetRngからdirect方向(xlUp,xlDown,xlToLeft,xlToRight)の 
' 次のデータを取得する（空白は読み飛ばす） 
' 末端の場合、第一引数に Nothing を返す 
'**************************************************** 
Function GetNextRngData(ByRef targetRng As Range, direct As XlDirection) 
     
    Dim index As Long 
    On Error GoTo ModuleEnd 
     
    '指定方向によって、セルを移動 
    Select Case direct 
        Case xlUp 
            Set targetRng = targetRng.Cells(0, 1) 
        Case xlDown 
            Set targetRng = targetRng.Cells(2, 1) 
        Case xlToLeft 
            Set targetRng = targetRng.Cells(1, 0) 
        Case xlToRight 
            Set targetRng = targetRng.Cells(1, 2) 
        Case Else 
    End Select 
     
    If targetRng.Value = "" Then 
    '隣接セルが空欄の場合 
        '値のあるとことまで進める 
        Set targetRng = targetRng.End(direct) 
    End If 
     
    If targetRng.Value = "" Then 
    'データが見つからない場合 
        Set targetRng = Nothing 
    End If 
 
    Exit Function 
 
ModuleEnd: 
    '末端まで探しに行ってもデータが見つからない 
    Set targetRng = Nothing 
     
End Function 

GetNextRngDataの第一引数(targetRng)は、呼び出し側でも移動します。ループの終了条件をこのtargetRngがNothingになるまでとすると、空欄のデータを考慮する必要がなくなります。

 
Sub test_GetNextRngData() 
     
    Dim Rng As Range 
     
    Set Rng = ActiveSheet.Range("A1") 
    Do While Not Rng Is Nothing 
             
        ' ==================== 
        '   Rngを使用した処理 
        ' ==================== 
         
        ' 次のデータまでRngを移動する。空欄セルは飛ばす 
        Call GetNextRngData(Rng, xlDown) 
    Loop 
 
End Sub 

条件に一致するセルを見つける

正規表現による検索で条件に一致するセルを見つけるモジュール。

エクセルマクロ(VBA)で正規表現を使用するならregExpオブジェクトを使用することになります。regExpオブジェクトは、Visual Basic Editor画面のツール「参照設定」にて「Microsoft VBScript Regular Expressions5.5」にチェックを入れる必要があります。

 
' ********************************************************************************** 
' 第一引数の Rng から第三引数の方向 direct(xlUp,xlDown,xlToLeft,xlToRight)に向かって、 
' 第二引数の条件 format(正規表現)を含むセルを探す 
'   完全一致セルを見つけたい場合は、format内で"^"と"$"で挟むこと 
' 見つかったセルを 第一引数の Rng で返す。見つからなければ、Rng が Nothing で戻る。 
' 第四引数の比較モード(vbBinaryCompare,vbTextCompare)  
'   vbBinaryCompareは、大文字と小文字を区別する 
'   vbTextCompareは、大文字と小文字を区別しない 
' ********************************************************************************** 
Function GetFomatCell(ByRef Rng As Range, format As String, direct As XlDirection, _ 
                                     comptype As VbCompareMethod) 
     
    Dim RegExpObj As regExp 
     
    '正規表現検索の初期値設定 
    Set RegExpObj = CreateObject("VBScript.RegExp") 
    RegExpObj.Global = True 
    '比較モード判定 
    If comptype = vbBinaryCompare Then 
        RegExpObj.IgnoreCase = True   '大文字/小文字の区別 
    ElseIf comptype = vbTextCompare Then 
        RegExpObj.IgnoreCase = False 
    Else 
        '初期値に従う 
    End If 
    '見つけるセルの条件 
    RegExpObj.pattern = format 
     
    Do While Not Rng Is Nothing 
        If RegExpObj.test(Rng.Text) = True Then 
            Exit Do 
        End If 
        Call GetNextRngData(Rng, direct) 
    Loop 
     
End Function 

先頭のセルが条件と一致する場合、Rngセルは移動せず、そのまま戻ります。このモジュールを呼び出す側でループする場合は、セルを移動させてから再度呼び出すようにしてください。

 
Sub test_GetFomatCell() 
     
    Dim Rng As Range 
    Dim format As String 
     
    Set Rng = ActiveSheet.Range("B1") 
    '条件 "数値(半角又は全角)月"と完全一致するセル 
    '    (大文字小文字は問わない vbTextCompare) 
    format = "^(\d+|[０-９]+)月$" 
    Call GetFomatCell(Rng, format, xlDown, vbTextCompare) 
     
    Do While Not Rng Is Nothing 
             
        ' ============================ 
        '    Rngは条件の一致するセル 
        ' ============================ 
         
        ' 次のデータまでRngを移動する。空欄セルは飛ばす 
        Call GetNextRngData(Rng, xlDown) 
        ' 条件の一致するセルまでRngを移動 
        Call GetFomatCell(Rng, format, xlDown, vbTextCompare) 
     
    Loop 
 
End Sub