[[20120316201345]]　『一致しない物の名前が知りたい』（ｷｭｱ）　ページの最後に飛ぶ

『一致しない物の名前が知りたい』（ｷｭｱ）

 AｼｰﾄとBｼｰﾄにある物の名前と番号を抜き出すには？
 Aｼｰﾄの番号と名前は重複しません。
 Bｼｰﾄの番号と名前は続く場合もあるし離れて出没することもあります。
 Cｼｰﾄに
 AｼｰﾄにあってBｼｰﾄにないもの
 BｼｰﾄにあってAｼｰﾄにないもの
 AｼｰﾄにもBｼｰﾄにもある件数　　以上3点の抜き出し方を教えてください。

 Aｼｰﾄ				Bｼｰﾄ		
番号	名前			番号	名前	
11	桃			99	ﾒﾛﾝ	
22	林檎			99	ﾒﾛﾝ	
555	蜜柑			11	桃	
33	檸檬			777	葡萄	
777	葡萄			777	葡萄	
88	西瓜			777	葡萄	
				22	林檎	
				777	葡萄	
				22	林檎	
				44	ﾊﾟｲﾝ

 AｼｰﾄにあってBｼｰﾄにないもの	　　BｼｰﾄにあってAｼｰﾄにないもの		
555	蜜柑			99	ﾒﾛﾝ	
33	檸檬			44	ﾊﾟｲﾝ	
88	西瓜

 AｼｰﾄにもBｼｰﾄにもあるものの件数　（つまり　桃、林檎、葡萄）						
 3

 2007　XP

 マクロで善ければ？

 AｼｰﾄのListは"Sheet1"、BｼｰﾄのListは"Sheet2"に在り、列見出しが有る物とします
 結果は"Sheet3"に出力されます

 Option Explicit

 Public Sub DataMatch()

    'Aｼｰﾄのデータ列数（A列～B列）
    Const clngColumnsA As Long = 2
    'Aｼｰﾄの比較する列の列位置(基準セル位置からの列Offset：A列)
    Const clngKeysA As Long = 0

    'Bｼｰﾄのデータ列数（A列～B列）
    Const clngColumnsB As Long = 2
    'Bｼｰﾄの比較する列の列位置(基準セル位置からの列Offset：A列)
    Const clngKeysB As Long = 0

    Dim rngListA As Range
    Dim vntListA As Variant
    Dim lngRowsA As Long
    Dim lngCompA As Long
    Dim rngListB As Range
    Dim vntListB As Variant
    Dim lngRowsB As Long
    Dim lngCompB As Long
    Dim lngMatch As Long
    Dim rngResultA As Range
    Dim rngResultB As Range
    Dim rngResultAB As Range
    Dim lngWriteA As Long
    Dim lngWriteB As Long
    Dim lngCountAB As Long
    Dim lngTmp As Long
    Dim strProm As String

    'AｼｰﾄのA1を基準とします(列見出しが有るとします)
    '★実際のシート名に変更する事
    Set rngListA = Worksheets("Sheet1").Cells(1, "A")

    'BｼｰﾄのA1を基準とする(列見出しが有るとします)
    '★実際のシート名に変更する事
    Set rngListB = Worksheets("Sheet2").Cells(1, "A")

    '画面更新を停止
    Application.ScreenUpdating = False

    '「結果出力」の位置を指定します
    '★実際のシート名に変更する事
    With Worksheets("Sheet3")
        Set rngResultA = .Cells(1, "A")
        Set rngResultB = .Cells(1, "E")
        Set rngResultAB = .Cells(1, "I")
        .UsedRange.ClearContents
    End With

    'Aｼｰﾄの基準に就いて
    If Not GetBasicData(rngListA, lngRowsA, _
            clngColumnsA, clngKeysA, vntListA) Then
        strProm = rngListA.Value & "にデータが有りません"
        GoTo Wayout
    End If

    'Bｼｰﾄ基準に就いて
    If Not GetBasicData(rngListB, lngRowsB, _
            clngColumnsB, clngKeysB, vntListB) Then
        strProm = rngListB.Value & "にデータが有りません"
        GoTo Wayout
    End If

    rngResultA.Value = "Aｼｰﾄに在って、Bｼｰﾄに無い物"
    rngResultB.Value = "Bｼｰﾄに在って、Aｼｰﾄに無い物"
    rngResultAB.Value = "AｼｰﾄにもBｼｰﾄにもある物の件数"

    'Aｼｰﾄの比較位置
    lngCompA = 1
    'Bｼｰﾄの比較位置
    lngCompB = 1
    'AｼｰﾄBｼｰﾄが共に最終行に達するまで繰り返し
    Do Until lngCompA > lngRowsA And lngCompB > lngRowsB
        '各列のデータを比較
        lngMatch = DataCompare(vntListA, lngCompA, vntListB, lngCompB)
        '比較結果に就いて
        Select Case lngMatch
            Case Is = 0 'Matchiした場合
                '出現をカウント
                lngCountAB = lngCountAB + 1
                Do
                    'Bｼｰﾄの比較位置を更新
                    lngCompB = lngCompB + 1
                Loop While vntListA(lngCompA, 1) = vntListB(lngCompB, 1)
                'Aｼｰﾄの比較位置を更新
                lngCompA = lngCompA + 1
            Case Is = -1 'Aｼｰﾄの固有値の場合
                'データを出力
                lngWriteA = lngWriteA + 1
                rngResultA.Offset(lngWriteA).Resize(, clngColumnsA).Value _
                        = rngListA.Offset(lngCompA).Resize(, clngColumnsA).Value
                'Aｼｰﾄのシートの比較位置を更新
                lngCompA = lngCompA + 1
            Case Is = 1  'Bｼｰﾄの固有値の場合
                'データを出力
                lngWriteB = lngWriteB + 1
                rngResultB.Offset(lngWriteB).Resize(, clngColumnsB).Value _
                        = rngListB.Offset(lngCompB).Resize(, clngColumnsB).Value
                lngTmp = lngCompB
                Do
                    'Bｼｰﾄの比較位置を更新
                    lngCompB = lngCompB + 1
                Loop While vntListB(lngTmp, 1) = vntListB(lngCompB, 1)
        End Select
    Loop

    'AｼｰﾄにもBｼｰﾄにもある物の件数を出力
    rngResultAB.Offset(1).Value = lngCountAB

    With rngListA
        'データの順番を元に戻す
        DataSort .Offset(1).Resize(lngRowsA, clngColumnsA + 1), .Offset(1, clngColumnsA)
        '復帰用連番を消去
        .Offset(1, clngColumnsA).EntireColumn.Clear
    End With

    With rngListB
        'データの順番を元に戻す
        DataSort .Offset(1).Resize(lngRowsB, clngColumnsB + 1), .Offset(1, clngColumnsB)
        '復帰用連番を消去
        .Offset(1, clngColumnsB).EntireColumn.Clear
    End With

    strProm = "処理が完了しました"

 Wayout:

    '画面更新を再開
    Application.ScreenUpdating = True

    Set rngListA = Nothing
    Set rngListB = Nothing
    Set rngResultA = Nothing
    Set rngResultB = Nothing

    MsgBox strProm, vbInformation

 End Sub

 Private Function GetBasicData(rngList As Range, _
                                lngRows As Long, _
                                lngColumns As Long, _
                                lngKeys As Long, _
                                vntData As Variant) As Boolean

    '基準に就いて
    With rngList
        '行数を取得
        lngRows = .Offset(.Parent.Rows.Count - .Row, lngKeys).End(xlUp).Row - .Row
        'データが無ければFunctionを抜ける(戻り値=False)
        If lngRows <= 0 Then
            Exit Function
        End If
        '最終列の後ろに復帰用連番を付与します
        With .Offset(1, lngColumns)
            .Value = 1
            .Resize(lngRows).DataSeries Rowcol:=xlColumns, _
                    Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
        End With
        'データをlngKeys列で整列
        DataSort .Offset(1).Resize(lngRows, lngColumns + 1), .Offset(1, lngKeys)
        '比較用配列にデータを取得
        vntData = .Offset(1, lngKeys).Resize(lngRows + 1).Value
    End With

    GetBasicData = True

 End Function

 Private Sub DataSort(rngScope As Range, _
                    rngKey As Range, _
                    Optional lngOrientation As Long = xlTopToBottom)

    rngScope.Sort _
            Key1:=rngKey, Order1:=xlAscending, _
            Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
            Orientation:=lngOrientation, SortMethod:=xlStroke

 End Sub

 Private Function DataCompare(vntKeys1 As Variant, lngPos1 As Long, _
                            vntKeys2 As Variant, lngPos2 As Long) As Long

 '  データの大小比較

    Dim i As Long

    '比較位置がDataEndを超えた場合
    If lngPos1 > UBound(vntKeys1, 1) - 1 Then
        DataCompare = 1
        Exit Function
    End If
    If lngPos2 > UBound(vntKeys2, 1) - 1 Then
        DataCompare = -1
        Exit Function
    End If

    'もし、Keyが不一致なら
    If vntKeys1(lngPos1, 1) = vntKeys2(lngPos2, 1) Then
        '戻り値の値として、「等しい」を返す
        DataCompare = 0
    Else
        'vntKeys1の値が、vntKeys2の値因り小さい場合
        If vntKeys1(lngPos1, 1) < vntKeys2(lngPos2, 1) Then
            '戻り値の値として、「小さい」を返す
            DataCompare = -1
        Else
            '戻り値の値として、「大きい」を返す
            DataCompare = 1
        End If
    End If

 End Function

 (Bun)

 ◆関数による回答です
 【Sheet1】					
	[A]	[B]			
[1]	番号	名前			
[2]	11	桃			
[3]	22	林檎			
[4]	555	蜜柑			
[5]	33	檸檬			
[6]	777	葡萄			
[7]	88	西瓜

 【Sheet2】					
	[A]	[B]			
[1]	番号	名前			
[2]	99	ﾒﾛﾝ			
[3]	99	ﾒﾛﾝ			
[4]	11	桃			
[5]	777	葡萄			
[6]	777	葡萄			
[7]	777	葡萄			
[8]	22	林檎			
[9]	777	葡萄			
[10]	22	林檎			
[11]	44	ﾊﾟｲﾝ

 【Sheet3】					
	[A]	[B]	[C]	[D]	[E]
[1]	AｼｰﾄにあってBｼｰﾄにないもの	BｼｰﾄにあってAｼｰﾄにないもの	
[2]	番号	名前		番号	名前
[3]	555	蜜柑		99	ﾒﾛﾝ
[4]	33	檸檬		44	ﾊﾟｲﾝ
[5]	88	西瓜			
[6]					
[7]					
[8]	AｼｰﾄにもBｼｰﾄにもあるものの件数				
[9]	3

 ◆Sheet3の式
 A3=IF(ROW(A1)>SUMPRODUCT((COUNTIF(Sheet2!$A$2:$A$20,Sheet1!$A$2:$A$20)=0)*(Sheet1!$A$2:$A$20<>"")),"",
 INDEX(Sheet1!$A$1:$A$20,SMALL(INDEX((COUNTIF(Sheet2!$A$2:$A$20,Sheet1!$A$2:$A$20)>0)*10^5+ROW($A$2:$A$20),),ROW(A1))))
 ★下にコピー

 B3=IF(A3="","",VLOOKUP(A3,Sheet1!$A$1:$B$20,2,0))

 D3=IFERROR(INDEX(Sheet2!$A$2:$A$20,SMALL(((COUNTIF(Sheet1!$A$2:$A$20,
 IFERROR((FREQUENCY(Sheet2!$A$2:$A$20,Sheet2!$A$2:$A$20)>0)*Sheet2!$A$2:$A$21,0))>0)
 +(IFERROR((FREQUENCY(Sheet2!$A$2:$A$20,Sheet2!$A$2:$A$20)>0)*Sheet2!$A$2:$A$21,0)=0))*10^5+ROW($A$1:$A$20),ROW(A1))),"")
 ★この式は「配列数式」です。式を入力後、CtrlとShiftを押しながらEnterを押して式を確定させてください
 ★式が確定すれば、式の両端に、｛　｝がつきます
 ★式を確定後に、下にコピー

 E3=IF(D3="","",VLOOKUP(D3,Sheet2!$A$1:$B$20,2,0))

 >AｼｰﾄにもBｼｰﾄにもあるものの件数
 A9=SUMPRODUCT((COUNTIF(Sheet2!$A$2:$A$20,Sheet1!$A$2:$A$20)>0)*1)
 (Maron)

 表の１行目には見出しが有るものとし
 表がA1セルから始まっている事を想定しています。

 考え方としては
 　Aシートの
 　 C列に、COUNTIF関数で　同じ番号がBシートに何回出てくるか数える
   Bシートの
    C列に、COUNTIF関数で　同じ番号がAシートに何回出てくるか数える

   Cシートには
    AシートのC列が「0」の物が Aシートにだけ有るもの
    BシートのC列が「0」の物が Bシートにだけ有るもの
    なので、フィルタオプションの設定で重複を除いて　抽出。

    また、AシートのC列が「0より大」の物が Bシートにも有るものなので
    COUNTIF関数で件数を数える。

 手作業でもそんなに大変な作業では無いとは思いますが
 　（頻度にもよるでしょうけれど。。。）
 コードが↓
 '------
Sub KyuA()
Const S_Sh1 As String = "Aシート" '←重複の無い方のシート
Const S_Sh2 As String = "Bシート" '←重複の有る方のシート
Const K_Sh1 As String = "Cシート" '←結果を出すシート名
    Dim MxR1 As Long, MxR2 As Long
    Dim MySh As Worksheet
Application.ScreenUpdating = False
    'S_Sh1にCOUNTIF関数を設定
    With Sheets(S_Sh1)
        MxR1 = .Range("A" & Rows.Count).End(xlUp).Row
        Call CntIfFx(S_Sh1, MxR1, S_Sh2)
        '両方に有るものの件数を数える
        .Range("D1").Value = "=COUNTIF(C1:C" & MxR1 & ","">0"")"
    End With
    'S_Sh2にCOUNTIF関数を設定
    With Sheets(S_Sh2)
        MxR2 = .Range("A" & Rows.Count).End(xlUp).Row
        Call CntIfFx(S_Sh2, MxR2, S_Sh1)
    End With

    With Sheets(K_Sh1)
        .Cells.ClearContents
    '検索条件設定
        .Range("I1").Value = "COUNTIF"
        .Range("I2").Value = 0
    'S_Sh1にだけ有るものを抽出＆ソート
        .Range("A1").Value = S_Sh1 & "にだけある"
         Call Adv_Sor("A", S_Sh1, MxR1, K_Sh1)
    'S_Sh2にだけ有るものを抽出＆ソート
        .Range("D1").Value = S_Sh2 & "にだけある"
         Call Adv_Sor("D", S_Sh2, MxR2, K_Sh1)
    '検索条件削除
        .Columns("I").Delete Shift:=xlToLeft
    '両方に有る物の件数を表示
        .Range("G1").Value = "両方にある件数"
        .Range("G2").Value = Sheets(S_Sh1).Range("D1").Value
    End With

    'COUNTIF関数を入れた列を削除
    For Each MySh In Sheets(Array(S_Sh1, S_Sh2))
        MySh.Columns("C:D").Delete Shift:=xlToLeft
    Next
Sheets(K_Sh1).Select
Application.ScreenUpdating = True
MsgBox "処理が終了しました。"
End Sub
'======
Sub CntIfFx(MySh As String, MxR As Long, AtSh As String)
    '列を挿入して、見出しと、COUNTIF関数を設定
    With Sheets(MySh)
        .Columns("C:D").Insert Shift:=xlToRight
        .Range("C1").Value = "COUNTIF"
        .Range("C2:C" & MxR).Value = "=COUNTIF(" & AtSh & "!A:A,A2)"
    End With
End Sub
'======
Sub Adv_Sor(MyC As String, MySh As String, MxR As Long, K_Sh As String)
    With Sheets(K_Sh)
    'フィルタオプションの設定でデータを抽出
        .Range(MyC & "2").Resize(, 2).Value = Sheets(MySh).Range("A1:B1").Value
        Sheets(MySh).Range("A1:C" & MxR).AdvancedFilter _
            Action:=xlFilterCopy, CriteriaRange:=.Range("I1:I2"), _
            CopyToRange:=.Range(MyC & "2").Resize(, 2), Unique:=True
    '並べ替え
        .Range(MyC & "2").Resize(.Range(MyC & Rows.Count).End(xlUp).Row, 2) _
            .Sort Key1:=.Range(MyC & "2"), Order1:=xlAscending, _
            Header:=xlYes, Orientation:=xlTopToBottom
    End With
End Sub
 '------

 (HANA)

 よく考えると、
 　重複がある方のシートのデータ量が
 　重複が無い方のシートのデータ量より少なく成る可能性
 って　有りますよね。

 「必ず多い」印象で作ってましたので、一部分ですが↑直接書き直しました。
 COUNTIF関数を設定する所が、なんだか大仰ですが。。。

 (HANA)

 やっぱり、Dictionaryを使った方が整列で処理するより簡単で速いかな？
 HANAさんが数式で処理している所を、Dictionaryで処理に変更した様な処理に成ります

 Option Explicit

 Public Sub DataMatch_2()

    'Dictionary版

    'Aｼｰﾄのデータ列数（A列～B列）
    Const clngColumnsA As Long = 2
    'Aｼｰﾄの比較する列の列位置(基準セル位置からの列Offset：A列)
    Const clngKeysA As Long = 0

    'Bｼｰﾄのデータ列数（A列～B列）
    Const clngColumnsB As Long = 2
    'Bｼｰﾄの比較する列の列位置(基準セル位置からの列Offset：A列)
    Const clngKeysB As Long = 0

    Dim i As Long
    Dim rngListA As Range
    Dim vntListA As Variant
    Dim lngRowsA As Long
    Dim lngFlagA() As Long
    Dim rngListB As Range
    Dim vntListB As Variant
    Dim lngRowsB As Long
    Dim lngFlagB() As Long
    Dim rngResultA As Range
    Dim rngResultB As Range
    Dim rngResultAB As Range
    Dim lngCountAB As Long
    Dim dicIndex As Object
    Dim strProm As String

    'AｼｰﾄのA1を基準とします(列見出しが有るとします)
    '★実際のシート名に変更する事
    Set rngListA = Worksheets("Sheet1").Cells(1, "A")

    'BｼｰﾄのA1を基準とする(列見出しが有るとします)
    '★実際のシート名に変更する事
    Set rngListB = Worksheets("Sheet2").Cells(1, "A")

    '画面更新を停止
    Application.ScreenUpdating = False

    '「結果出力」の位置を指定します
    '★実際のシート名に変更する事
    With Worksheets("Sheet3")
        Set rngResultA = .Cells(1, "A")
        Set rngResultB = .Cells(1, "E")
        Set rngResultAB = .Cells(1, "I")
        .UsedRange.ClearContents
    End With

    'Dictionaryオブジェクトを取得
    Set dicIndex = CreateObject("Scripting.Dictionary")

    'Aｼｰﾄの基準に就いて
    If Not GetBasicData(rngListA, lngRowsA, clngKeysA, vntListA) Then
        strProm = rngListA.Value & "にデータが有りません"
        GoTo Wayout
    End If
    '抽出Flagを確保
    ReDim lngFlagA(1 To lngRowsA, 1 To 1)

    'Bｼｰﾄ基準に就いて
    If Not GetBasicData(rngListB, lngRowsB, clngKeysB, vntListB) Then
        strProm = rngListB.Value & "にデータが有りません"
        GoTo Wayout
    End If
    '抽出Flagを確保
    ReDim lngFlagB(1 To lngRowsB, 1 To 1)

    With dicIndex
        'Bシートの値をDictionaryに登録
        For i = 1 To lngRowsB
            If .Exists(vntListB(i, 1)) Then
                '登録が在ったらFlagを立てる
                lngFlagB(i, 1) = 1
            Else
                '無ければ、行番号をItemとして登録
                .Item(vntListB(i, 1)) = i
            End If
        Next i
        'Aシートの値がDictionaryに在るかを確認
        For i = 1 To lngRowsA
            '登録が在ったら
            If .Exists(vntListA(i, 1)) Then
                'Matchしたとしてカウント
                lngCountAB = lngCountAB + 1
                'AシートにFlagを立てる
                lngFlagA(i, 1) = 1
                'BシートにFlagを立てる
                lngFlagB(.Item(vntListA(i, 1)), 1) = 1
            End If
        Next i
    End With

    '出力範囲に結果を出力
    OutPut rngListA, rngResultA, clngColumnsA, lngRowsA, lngFlagA, _
            rngListA.Parent.Name & "に在って、" & rngListB.Parent.Name & "に無い物"

    '出力範囲に結果を出力
    OutPut rngListB, rngResultB, clngColumnsB, lngRowsB, lngFlagB, _
            rngListB.Parent.Name & "に在って、" & rngListA.Parent.Name & "に無い物"

    With rngResultAB
        .Value = rngListA.Parent.Name & "にも" & rngListA.Parent.Name & "にもある物の件数"
        .Offset(1).Value = lngCountAB
    End With

    strProm = "処理が完了しました"

 Wayout:

    '画面更新を再開
    Application.ScreenUpdating = True

    Set rngListA = Nothing
    Set rngListB = Nothing
    Set rngResultA = Nothing
    Set rngResultB = Nothing
    Set rngResultAB = Nothing
    Set dicIndex = Nothing

    MsgBox strProm , vbInformation

 End Sub

 Private Function GetBasicData(rngList As Range, _
                                lngRows As Long, _
                                lngKeys As Long, _
                                vntData As Variant) As Boolean

    '基準に就いて
    With rngList
        '行数を取得
        lngRows = .Offset(.Parent.Rows.Count - .Row, lngKeys).End(xlUp).Row - .Row
        'データが無ければFunctionを抜ける(戻り値=False)
        If lngRows <= 0 Then
            Exit Function
        End If
        '比較用配列にデータを取得
        vntData = .Offset(1, lngKeys).Resize(lngRows + 1).Value
    End With

    GetBasicData = True

End Function

 Private Sub OutPut(rngList As Range, rngResl As Range, lngColu As Long, lngRows As Long, lngF() As Long, strProm As String)

    Const cstrNum As String = "No"

    '出力範囲に題名等を出力
    With rngResl
        .Value = strProm
        rngList.Resize(1, lngColu).Copy Destination:=.Offset(1)
        .Offset(1, lngColu).Value = cstrNum
        .Offset(2, lngColu).Value = "=0"
    End With

    With rngList
        'Flagを出力
        .Offset(, lngColu).Value = cstrNum
        .Offset(1, lngColu).Resize(lngRows).Value = lngF
    End With

    'シートのデータをフィルタ出力
    DoFilter rngList.Resize(lngRows + 1, lngColu + 1), _
            rngResl.Offset(1, lngColu).Resize(2), _
            rngResl.Offset(1).Resize(, lngColu)

    '作業列をクリア
    rngResl.Offset(1, lngColu).Resize(2).ClearContents
    rngList.Offset(, lngColu).EntireColumn.ClearContents

 End Sub

 Private Sub DoFilter(rngScope As Range, _
                    rngCriteria As Range, _
                    rngCopyTo As Range, _
                    Optional blnUnique As Boolean)

 '  AdvancedFilterを実行

    rngScope.AdvancedFilter _
            Action:=xlFilterCopy, _
            CriteriaRange:=rngCriteria, _
            CopyToRange:=rngCopyTo, _
            Unique:=blnUnique

 End Sub

 (Bun)

Dictionaryを繰り返し使用してみました（マナ）

 Sub test()
    Dim dicA As Object, dicB As Object, dicC As Object, dicBonly As Object, dicAonly As Object
    Dim rngA As Range, rngB As Range
    Dim c
    Dim keyAonly, keyBonly, itemAonly, itemBonly
    Dim i As Long
    Dim V1(), V2()

    Set dicA = CreateObject("Scripting.Dictionary")
    Set dicB = CreateObject("Scripting.Dictionary")
    Set dicBonly = CreateObject("Scripting.Dictionary")
    Set dicAonly = CreateObject("Scripting.Dictionary")
    Set dicC = CreateObject("Scripting.Dictionary")

    Set rngA = Sheets("Aシート").Range("A2", Sheets("Aシート").Cells(Rows.Count, 1).End(xlUp))
    Set rngB = Sheets("Bシート").Range("A2", Sheets("Bシート").Cells(Rows.Count, 1).End(xlUp))

    'A一覧取得
    For Each c In rngA
        If Len(c.Value) > 0 Then
            dicA(c.Value) = c.Offset(, 1).Value
        End If
    Next

    'B一覧取得
    For Each c In rngB
        If Len(c.Value) > 0 Then
            If Not dicB.exists(c.Value) Then
                dicB(c.Value) = c.Offset(, 1).Value
            End If
        End If
    Next

    'Aのみ
    For Each c In dicA.keys
        If Not dicB.exists(c) Then
            dicAonly(c) = dicA(c)
        End If
    Next
    keyAonly = dicAonly.keys
    itemAonly = dicAonly.items

    If dicAonly.Count > 0 Then
        ReDim V1(1 To dicAonly.Count, 1 To 2)
        For i = 1 To dicAonly.Count
            V1(i, 1) = keyAonly(i - 1)
            V1(i, 2) = itemAonly(i - 1)
        Next
    Else
        ReDim V1(1 To 1, 1 To 2)
        V1(1, 1) = "ありません"
    End If

    'Bのみ
    For Each c In dicB.keys
        If Not dicA.exists(c) Then
            dicBonly(c) = dicB(c)
        End If
    Next
    keyBonly = dicBonly.keys
    itemBonly = dicBonly.items

    If dicBonly.Count > 0 Then
        ReDim V2(1 To dicBonly.Count, 1 To 2)
        For i = 1 To dicBonly.Count
            V2(i, 1) = keyBonly(i - 1)
            V2(i, 2) = itemBonly(i - 1)
        Next
    Else
        ReDim V2(1 To 1, 1 To 2)
        V2(1, 1) = "ありません"
    End If

    '両方あるもの
    For Each c In dicA.keys
        If dicB.exists(c) Then
            dicC(c) = dicB(c)
        End If
    Next
    For Each c In dicB.keys
        If dicA.exists(c) Then
            dicC(c) = dicA(c)
        End If
    Next

    With Sheets("Cシート")
        .Columns("A:H").ClearContents
        .Range("A1").Value = "AにあってBにない"
        .Range("A2").Resize(UBound(V1), 2).Value = V1
        .Range("D1").Value = "BにあってAにない"
        .Range("D2").Resize(UBound(V2), 2).Value = V2
        .Range("G1").Value = "両方にある"
        .Range("G2").Value = dicC.Count & "件"
        .Select
    End With

    Set rngA = Nothing
    Set rngB = Nothing

    Set dicA = Nothing
    Set dicB = Nothing
    Set dicBonly = Nothing
    Set dicAonly = Nothing
    Set dicC = Nothing

 End Sub

こんにちは、ありがとうございました。

できましたって言っていいのかわかりませんが、とにかく求めたいものが表示されました。

皆さんの知識に圧倒されっぱなしでなんというか恐縮しております。

ｷｭｱ

コメント返信：

[ 一覧(最新更新順) ]

[[20120316201345]] 『一致しない物の名前が知りたい』（ｷｭｱ） ページの最後に飛ぶ

[[20120316201345]]　『一致しない物の名前が知りたい』（ｷｭｱ）　ページの最後に飛ぶ