【エクセル・マクロ・VBA】二語をキーとして異なるデータに１をたてる

二語をキーとして異なるデータに１をたてる

このVBAコードは、2つのシートにある単語のディクショナリーを作成して、それらの単語が最初のシートに存在するかどうかをチェックするものです。

Sub 二つの単語_ディクショナリ_シート間処理()

Dim sheet_1 As Worksheet, sheet_2 As Worksheet
Set sheet_1 = ActiveSheet
Set sheet_2 = ActiveSheet.Next

Dim LastLow1 As Long, LastLow2 As Long, LastCol1 As Long, LastCol2 As Long
LastLow1 = sheet_1.Cells(Rows.Count, 1).End(xlUp).Row
LastCol1 = sheet_1.Cells(2, Columns.Count).End(xlToLeft).Column
LastLow2 = sheet_2.Cells(Rows.Count, 1).End(xlUp).Row
LastCol2 = sheet_2.Cells(2, Columns.Count).End(xlToLeft).Column

Dim myDic As Object, myKey
Dim i As Long
    Set myDic = CreateObject("Scripting.Dictionary")

'相手のシート
On Error Resume Next
For i = 2 To LastLow2
    sheet_2.Cells(i, LastCol2 + 1).Value = "1"
         
    If Not myDic.Exists(sheet_2.Cells(i, 1).Value & "," & sheet_2.Cells(i, 2).Value) Then
        myDic.Add (sheet_2.Cells(i, 1).Value & "," & sheet_2.Cells(i, 2).Value), (sheet_2.Cells(i, LastCol2 + 1).Value)
    End If
Next i

For i = 2 To LastLow1
    If Not myDic.Exists(sheet_1.Cells(i, 1).Value & "," & sheet_1.Cells(i, 2).Value) Then
        sheet_1.Cells(i, LastCol1 + 1).Value = myDic.Item(sheet_2.Cells(i, 1).Value & "," & sheet_2.Cells(i, 2).Value)

    End If
Next i
 
On Error GoTo 0

Set myDic = Nothing
Set sheet_1 = Nothing
Set sheet_2 = Nothing

MsgBox "完了"
End Sub

解説

まず、sheet_1とsheet_2変数を定義し、それらをアクティブシートとアクティブシートの隣のシートに設定します。それから、それぞれのシートの最後の行と最後の列を決定し、ディクショナリー変数myDicを作成します。

次に、LastLow2変数の範囲内で、sheet_2シート内の各単語を走査し、新しい列に1を設定します。そして、単語がディクショナリーに存在しない場合は、myDic変数に単語を追加します。

最後に、LastLow1変数の範囲内で、各単語を走査し、ディクショナリーに存在しない場合は、単語が最初のシートにないことを示す新しい列に1を設定します。

このコードの改善点としては、On Error Resume Nextステートメントはエラーを無視するために使用されているため、エラーをキャッチしやすくするために削除することができます。また、myDicのアイテムを呼び出す際に、不必要な括弧が使用されているため、これを修正することもできます。

さらに、処理の高速化のために、各シートのデータをメモリ内の配列に読み込むことができます。また、myDic変数をVariant型にすることもできます。Variant型の場合、自動的に最適なデータ型を割り当てるため、処理速度が向上する可能性があります。

最後に、このコードは、単語が1列にまとめられた場合にのみ機能します。もし複数列にまたがる場合は、デリミターを変更する必要があります。

複数条件で一致したものを別シート転記

このVBAマクロは、複数の条件に一致する場合に、別のシートに抽出するために使用されます。以下、コードの行ごとに解説していきます。

Sub 複数の条件があうものを抽出()

'Vlookのような使い方

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim MyList() As Variant
Dim LastRow As Long
Dim i As Long
Dim j As Long

    Set ws1 = ActiveSheet
    Set ws2 = ActiveSheet.Next

    '「単価表」シート A列～C列(Resize(, 3))のデータを配列に格納
    ws1.Select　'不要？削除可能
    MyList = ws1.Range("A2", Range("A" & Rows.Count). _
                     End(xlUp)).Resize(, 3).Value

    '最終行
    LastRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row

    '「抽出」シート ループ
    For i = 1 To LastRow

        For j = 1 To UBound(MyList)

            '複数条件一致で別シート転記
            If ws1.Cells(i, 1) = MyList(j, 1) And _
                    ws1.Cells(i, 2) = MyList(j, 2) Then

                ws1.Cells(i, 5) = MyList(j, 3)

            End If
        Next j
    Next
MsgBox "完了"
End Sub

解説

このコードは、”複数の条件があうものを抽出”という名前のサブルーチンを定義しています。
Dim 文は、VBA変数を宣言します。
ws1 はアクティブシート（現在アクティブなExcelシート）を参照し、 ws2 は次のシートを参照しています。
MyList は可変型配列で、A列からC列までのデータを保持するために使用されます。
LastRow は、 ws2 で使用するために最終行の行番号を保持するために使用されます。
i と j は、後続の For ループのカウンターとして使用されます。
MyList 配列に、ws1シートのA列からC列までのデータを取得します。
Resize() メソッドは、指定した範囲を拡大または縮小するために使用されます。上記の例では、A列からC列にデータを拡張します。
End(xlUp) は、指定された範囲の最後のセルを検索するために使用されます。上記の例では、A列の最後の行までを取得します。
Value プロパティは、指定した範囲の値を取得します。
Rows.Count プロパティは、シート内の行数を取得します。
Cells() メソッドは、指定された行と列のセルを参照します。
End(xlUp) は、指定された範囲の最後のセルを検索するために使用されます。

【マクロ・VBA】アクティブシートと右隣りのシート間で二語をキーとして異なるデータに１をたてる

二語をキーとして異なるデータに１をたてる

解説

複数条件で一致したものを別シート転記

解説

コメント