VBAのIndex Match関数は、Excelのインデックスとマッチ関数と同様に、ある範囲内で検索を行い、条件に一致する値を取得するために使用される関数です。
Index・Machの構文
Application.WorksheetFunction.Index(range, Application.WorksheetFunction.Match(lookup_value, lookup_range, match_type))- range: 検索対象の範囲を指定します。
- lookup_value: 検索する値を指定します。
- lookup_range: 検索対象の範囲を指定します。
- match_type: 検索の種類を指定します。
Index・Machの使用例
例として、範囲A1:B10から、「Apple」という文字列を検索し、その行の2列目の値を取得するという処理を行います。
Sub IndexMatchExample()
Dim rng As Range
Dim result As Variant
Set rng = Range("A1:B10")
result = Application.WorksheetFunction.Index(rng, Application.WorksheetFunction.Match("Apple", rng.Columns(1), 0), 2)
MsgBox result
End Subこの例では、範囲A1:B10を「rng」というオブジェクトに設定し、Application.WorksheetFunction.Index関数を使用して、「Apple」を検索し、その行の2列目の値を取得しています。Match関数は、検索対象の範囲の1列目を検索し、0を指定して完全一致検索を行っています。
アクティブなシートと右隣のシートを比較して、複数のキーワードが含まれているかを確認し、該当するセルにカラーをつける
Sub IndexMatchExample()
Dim activeSheet As Worksheet
Dim targetSheet As Worksheet
Dim activeRange As Range
Dim targetRange As Range
Dim cell As Range
Dim keywords As Variant
Dim keyword As Variant
'アクティブなシートと右隣のシートを取得
Set activeSheet = ActiveSheet
Set targetSheet = activeSheet.Next
'アクティブなシートの使用範囲と、検索対象シートの使用範囲を取得
Set activeRange = activeSheet.UsedRange
Set targetRange = targetSheet.UsedRange
'検索するキーワードを設定
keywords = Array("apple", "banana", "orange")
'アクティブなシートのセルを順番にチェックし、キーワードが含まれている場合は、検索対象シートの同じセルにカラーをつける
For Each cell In activeRange
For Each keyword In keywords
If InStr(1, cell.Value, keyword, vbTextCompare) > 0 Then
targetSheet.Range(cell.Address).Interior.ColorIndex = 6
End If
Next keyword
Next cell
End Subこの例では、まずアクティブなシートと右隣のシートを取得し、それぞれの使用範囲を取得しています。次に、検索するキーワードを設定し、アクティブなシートのセルを順番にチェックして、キーワードが含まれている場合は、検索対象シートの同じセルにカラーをつける処理を行っています。
キーワードが複数ある場合は、For Each文で順番にチェックしています。また、キーワードの比較にはInStr関数を使用しています。InStr関数は、指定した文字列に指定した文字列が含まれている場合にその位置を返す関数で、vbTextCompareを指定することで大文字小文字を区別しない比較を行います。
シート間の行項目と列項目に従いIndex・Machでマッチングする
Sub インデックスマッチをディクショナリ()
'元表------------------------------
Dim ws1 As Worksheet
Set ws1 = ActiveSheet
'------------------------------------
'転記先----------------------------
Dim ws2 As Worksheet
Set ws2 = ActiveSheet.Next
'------------------------------------
'基表シート＿ディクショナリ作成------
Dim dicGyoukoumoku As Object
Set dicGyoukoumoku = CreateObject("Scripting.Dictionary")
Dim dicRetukoumoku As Object
Set dicRetukoumoku = CreateObject("Scripting.Dictionary")
Const WS1_KEY_ROW As Long = 1
Const WS1_KEY_CLM As Long = 1
'基表の行項目をディクショナリに保管
Dim iRRow As Long
For iRRow = 2 To ws1.Cells(Rows.Count, WS1_KEY_CLM).End(xlUp).Row
'キー（のデータ）の行番号をディクショナリに保管（同じデータが複数あった場合、後のものの行番号で上書き）
dicGyoukoumoku(ws1.Cells(iRRow, "A").Value) = iRRow
Next
'基表の列項目をディクショナリに保管
Dim iRCol As Long
For iRCol = 2 To ws1.Cells(WS1_KEY_CLM, Columns.Count).End(xlToLeft).Column
dicRetukoumoku(ws1.Cells(1, iRCol).Value) = iRCol
Next
'-------------------------------------------
'転記先シート＿転記処理----------------
Dim iWRow As Long '転記先シートの出力行
Dim iWCol As Long '転記先シートの出力列
Const WS2_CLM As Long = 1
Const WS2_ROW As Long = 1
'行項目ループ＿２行目から
For iWRow = 2 To ws2.Cells(2, WS2_CLM).End(xlDown).Row
'もし転記先のキーのデータがディクショナリに無かった場合
If dicGyoukoumoku.Item(ws2.Cells(iWRow, WS2_CLM).Value) = "" Then
'何もしない
Else
'上記以外（あった場合）iRROWに行番号を保管
iRRow = dicGyoukoumoku.Item(ws2.Cells(iWRow, WS2_CLM).Value)
'列項目ループ
For iWCol = 1 To ws1.Cells(WS2_ROW, 1).End(xlToRight).Column
If dicRetukoumoku.Item(ws2.Cells(WS2_ROW, iWCol).Value) = "" Then
'何もしない
Else
'上記以外（あった場合）iRROWに列番号を保管
iRCol = dicRetukoumoku.Item(ws2.Cells(WS2_ROW, iWCol).Value)
'「基表（アクティブシート）」シートの取得行・取得列のセルの値を、「転記先（アクティブシート右隣り）」シートの出力行・出力列に出力する
ws2.Cells(iWRow, iWCol).Value = ws1.Cells(iRRow, iRCol).Value
End If
Next iWCol
End If
Next iWRow
MsgBox "完了"
End Sub相手シートの行の項目と列の項目に従い転記
Sub インデックスマッチをディクショナリ()
Const KENSAKU_CLM As Long = 1 '「転記先」シートＢ列（社名列：C列）
Const KENSAKU_ROW As Long = 1 '「転記先」シート４行目（項目見出し行:4行目）
Const MOTO_KEY_CLM As Long = 1 '「元表」シートのキー列（社名列：C列）
Const MOTO_KEY_ROW As Long = 1 '「元表」シートのキー行（項目見出し行:７行目）
Dim Sh_Moto As Worksheet '「元表」シート
Dim Sh_Tenki As Worksheet '「転記先」シート
'Dictionaryオブジェクトの宣言
Dim dicShamei As Object '元表の社名行番号ディクショナリ
Dim dicKomoku As Object '元表の項目名列番号ディクショナリ
Dim iRRow As Long '元表シートの読込行
Dim iRCol As Long '元表シートの読込列
Dim iWRow As Long '転記先シートの出力行
Dim iWCol As Long '転記先シートの出力列
Set Sh_Moto = Worksheets("元表")
Set Sh_Tenki = Worksheets("転記先")
Set dicShamei = CreateObject("Scripting.Dictionary")
Set dicKomoku = CreateObject("Scripting.Dictionary")
'【ディクショナリ作成】
'元表シート（8行目から最終行）から社名のディクショナリを作成
For iRRow = 2 To Sh_Moto.Cells(2, MOTO_KEY_CLM).End(xlDown).Row
'社名をキーとして行番号をディクショナリに保管（同じ社名が複数存在した場合、後勝ちで行番号が上書きされます）
dicShamei(Sh_Moto.Cells(iRRow, "A").Value) = iRRow
Next
'元表シート（2列目から最終列）から項目名のディクショナリを作成
For iRCol = 2 To Sh_Moto.Cells(MOTO_KEY_ROW, 1).End(xlToRight).Column
'項目名をキーとして列番号をディクショナリに保管
dicKomoku(Sh_Moto.Cells(1, iRCol).Value) = iRCol '7行目の列の値
Next
'【転記処理】
'転記先シート（5行目から最終行）の社名ループ
For iWRow = 2 To Sh_Tenki.Cells(2, KENSAKU_CLM).End(xlDown).Row
'社名から元表の行番号を取得
If dicShamei.Item(Sh_Tenki.Cells(iWRow, KENSAKU_CLM).Value) = "" Then
'社名から行番号が取得できない場合は何もしない
Else
'元表の行番号を取得
iRRow = dicShamei.Item(Sh_Tenki.Cells(iWRow, KENSAKU_CLM).Value)
'転記先シートの項目ループ
For iWCol = 1 To Sh_Moto.Cells(KENSAKU_ROW, 1).End(xlToRight).Column
'項目名から元表の列番号を取得
If dicKomoku.Item(Sh_Tenki.Cells(KENSAKU_ROW, iWCol).Value) = "" Then
'項目名から列番号が取得できない場合は何もしない
Else
'元表の列番号を取得
iRCol = dicKomoku.Item(Sh_Tenki.Cells(KENSAKU_ROW, iWCol).Value)
'「元表」シートの取得行・取得列のセルの値を、「転記先」シートの出力行・出力列に出力する
Sh_Tenki.Cells(iWRow, iWCol).Value = Sh_Moto.Cells(iRRow, iRCol).Value
End If
Next iWCol
End If
Next iWRow
MsgBox "完了"
End Sub
コメント