Excelシート内のデータ集合2群の要素の差を出力するVBA

内容

Excelシート内で、下記のような調査を行うことが多々あります。

集合A	集合B
This	This
column	aulumn
will	will
be	become

⇒集合Aの要素にはcolumnが1回、beが1回多く登場
　集合Bの要素にはautumnが1回、becomeが1回多く登場。
4個だったら目で見て分かりますが、10万行とかあると大変です。

たぶん多くの事務作業者にとっての頻出作業なので、ネットにも方法がたくさん出てきます。ただその多くは、=countif(B:B,A1)とかvlookupなどをセルの横に張り付けて、そのあと下にコピペしていくという、というもので、これだとB:Bから対象があるかを数えるという作業をAデータの存在する数だけ繰り返すので、1000行とかならいけますが、A・Bデータが10万行ずつとかになると、（単純に考えれば10万×10万の計算が行われるため）エクセルが固ったりします。

関数でやるよりもVBAで、辞書型で登場回数をカウント（集合Aの要素は＋でカウント、集合Bの要素は－でカウント）、合計が0でないものを出力するとすれば速いはず！と思って作ったのが下記です。50万個ずつでも（差が少なければ普通のPCでも）数秒で終わります。

使い方

使い方は、以下のコードを個人用マクロモジュールにでも貼り付けて、見たい差のデータがあるワークシートをアクティブにした状態でMain_ShowDifferenceBetweenColumnsInActiveSheet()を実行すればOKです。

Option Explicit
Sub Main_ShowDifferenceBetweenColumnsInActiveSheet()
'参照設定:"Microsoft Scripting Runtime"
'重複したデータの値を合計して表示
    Dim myDic As Object 'Dictionary
    Dim i As Long, v As Variant, myStr1 As String, myStr2 As String
    Set myDic = CreateObject("Scripting.Dictionary")
    Dim targetArray1 As Variant, targetArray2 As Variant
    '以下のInputBoxでは、RangeをSetしているのではなく、Range内のValueを取得しているだけであることに注意する。
    targetArray1 = selectSampleByUser("1つめのサンプルを選択してください。列は選択できません。") 'Range(Cells(1, 1), Cells(10, 1))
    targetArray2 = selectSampleByUser("2つめのサンプルを選択してください。列は選択できません。") 'Range(Cells(1, 3), Cells(10, 3))
    Call addValue2Key(myDic, targetArray1, 1)
    Call addValue2Key(myDic, targetArray2, -1)
    Call outputKeys(myDic)
    Set myDic = Nothing
End Sub

Private Function selectSampleByUser(msg As String) As Range
    'InputBoxを表示して、ユーザーから列でないセル選択範囲を指定してもらい、それを返す関数。
    Dim inputRange As Range
    On Error Resume Next
        Set inputRange = Application.InputBox(Prompt:=msg, Type:=8)
    On Error GoTo 0
    If inputRange Is Nothing Then End
    Dim bottomRow As Long
    'このCountで何をやっているかについては以下のサイトがわかりやすいhttp://officetanaka.net/excel/vba/tips/tips111.htm
    bottomRow = inputRange(inputRange.Count).Row
    If bottomRow > 1000000 Then
        MsgBox "ちょっと指定範囲が多すぎると思います"
        End
    End If
    Set selectSampleByUser = inputRange
End Function

Private Sub addValue2Key(ByRef target_dict As Object, ByVal array_range As Variant, value_added As Long)
    'target_dictはDictionary型
    Dim i As Long
    Dim myKey As Variant
    For Each myKey In array_range
        If target_dict.Exists(myKey) Then
            target_dict(myKey) = target_dict(myKey) + value_added
            If target_dict(myKey) = 0 Then
                'ここで不要なKeyをせっせと除くことで、最後に出力する際の検索が速くなる。
                target_dict.Remove myKey
            End If
        Else
            target_dict.Add myKey, value_added
        End If
    Next
End Sub

Private Sub outputKeys(ByRef target_dict As Object) 'Dictionary)
    Dim wbAdded As Workbook
    Set wbAdded = Workbooks.Add ' ワークブックを作成
    Dim i As Long, j As Long, k As Long
    Dim col1_key As Long, col1_num As Long, col2_key As Long, col2_num
    j = 1: k = 1
    col1_key = 1
    col1_num = col1_key + 1
    col2_key = col1_key + 2
    col2_num = col1_key + 3
    With wbAdded.Worksheets(1)
        .Cells(j, col1_key).Value = "指定1に多く登場"
        .Cells(j, col1_num).Value = "登場回数差"
        j = j + 1
        .Cells(k, col2_key).Value = "指定2に多く登場"
        .Cells(k, col2_num).Value = "登場回数差"
        k = k + 1
        For i = 1 To target_dict.Count
            If target_dict.Items()(i - 1) > 0 Then
            '細かいことをいうと.Items,.Keysは配列を返すメソッドであり()が必要だが、参照設定をすればこの()は付けなくて済むようだ。
            '参照設定なしで済ませたいので今回は()が必要。
                .Cells(j, col1_key).Value = target_dict.Keys()(i - 1)
                .Cells(j, col1_num).Value = target_dict.Items()(i - 1)
                j = j + 1
            ElseIf target_dict.Items()(i - 1) < 0 Then
                .Cells(k, col2_key).Value = target_dict.Keys()(i - 1)
                .Cells(k, col2_num).Value = target_dict.Items()(i - 1) * (-1)
                k = k + 1
            End If
        Next i
    End With
End Sub

性能についてテスト

• 要素が各1万個程度でも、2つの集合で異なる要素が多いとかなり時間がかかる。
  • 試しに「=RANDBETWEEN(0,10000)」をA1セル～B10000セルにコピー&値貼り付けした後、A列とB列で比べてみたら4秒くらいかかった。
• 要素が各10万個程度でも、2つの集合で異なる要素が少ないと速い。
  • A1セル～A100000セルに「=RANDBETWEEN(0,10000)」の値貼り付けを作成、B列にA列と同じ数値を張り付けてテストしたところ2秒程度で終了。ちなみにA列とB列で順番を逆順にしてみても時間は変わらなかった。

課題

• コードの最後で、セル1つずつに張り付けていく部分があるが、これは速度の観点から望ましくない。おそらく、一度配列に格納して、最後にセルに1度に貼り付けるのが望ましいと思う。だが辞書のKeyやItemを、正負の条件を満たすものに絞って配列化するスマートな方法がぱっと思いつかず諦めた。
• 現状のコードで、異なる要素が多いと時間がかかるのは、Itemsをindexで指定して繰り返し出力していく部分に時間がかかるためだと思う。うまいことやればもっと高速化できる気がするし、したいのはやまやまなのだが、そのためにはDictionaryの実装がどうなっているのかとか、もうちょっと詳しく調べる必要がある気がする。