[[20110623151753]]　『別シートを比較して重複しないデータを抽出する』（ぷち）　ページの最後に飛ぶ

『別シートを比較して重複しないデータを抽出する』（ぷち）

 excel2007を使用しています。
 Sheet1、sheet2それぞれ以下のようにデータが入っています。
 それぞれ1行目は見出しとなっています。

 ＜sheet1＞
 ｜ 部 ｜ 課 ｜担当｜氏名｜
 ｜ ○ ｜ × ｜ △ ｜ Ａ ｜
 ｜ □ ｜ △ ｜ △ ｜ Ｂ ｜
 ｜ ○ ｜ ○ ｜ △ ｜ Ａ ｜
 ｜ ○ ｜ ○ ｜ △ ｜ Ｃ ｜
 ｜ ○ ｜ ○ ｜ △ ｜ Ｃ ｜

 ＜sheet2＞
 ｜ 部 ｜ 課 ｜担当｜氏名｜
 ｜ ○ ｜ × ｜ △ ｜ Ａ ｜
 ｜ □ ｜ △ ｜ △ ｜ Ｂ ｜
 ｜ ○ ｜ ○ ｜ △ ｜ Ａ ｜
 ｜ ○ ｜ ○ ｜ △ ｜ Ｄ ｜
 ｜ ○ ｜ ○ ｜ △ ｜ Ｃ ｜

 Sheet1とsheet2を「氏名」とキーとして比較し、
 重複しない「氏名」を含む行をsheet1からsheet3へ抽出したいです。
 （sheet1にあってsheet2にないものを別シートへ抽出したい）
 この作業をマクロで行うことはできますでしょうか？
 分りづらい文章で申し訳ございません。

 この場合、○部×課△担当のＡさんと、○部○課△担当のＡさんは同一人物ですか？
 氏名のみキーとするのであれば、同一人物と看做されますので。
 (ROUGE)

 お返事ありがとうございます。
 そうですね、書き方に問題がありました。
 氏名が同じであれば部・課・担当も同じということでＯＫです。(ぷち)

 Sheet1に重複があって、それがSheet2になかった時、別シートへは１件だけ反映するのか、
 それとも、重複しているものを全て反映するのか、それによってロジックは少し変るけど
 前者であれば手っ取り早くやろうとすれば、Sheet1の名前をDictionary(A)に、
 Sheet2の名前をDictionary(B)にいれておいて、Dictionary(A)の要素でDIctionary(B)にないものを
 配列に格納していって、最後に別シートに、どさっと転記。
 Match関数（あるいはFindメソッド)を使う手もあるけど,ロジックがやや煩雑になるうえに、
 Dictionary処理に比べて効率はガクンと落ちる。
 後者であれば、ちょっと工夫が要るけど、基本、同じような処理になる。

 もう１つ手があった。処理時間は、こちらのほうが大幅に短縮されるはず。
 ただし、上で書いた前者のみ。
 フィルターオプション(AdvancedFilter)を使う方法。

 いずれにしても前者か後者かを教えてほしいな。

 ぶらっと立ち寄り

 私の理解力不足で大変申し訳ないですが、前者で良いと思います。
 具体的にやりたい事を書きますと、
 ・sheet1には社員全員分の所属と名前が入っている（sheet1の中で重複は無い）
 ・sheet2には、同じように所属・氏名　それに加えてその人が持っている資格のデータが入っている。
 ・よって、sheet1に名前があってsheet2に名前が無い人を別シートに抽出し、資格を持っていない人の所属と名前の一覧を作りたい

 …という事なのですが、具体的にイメージしていただけるでしょうか?_?
 (ぷち）

 とりあえず。提示された例だと、一件も抽出されまへんですた。(ROUGE)
　
Sub Buchi()
Dim tbl, ky, i As Long
With CreateObject("Scripting.Dictionary")
    tbl = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 4).Value
    For i = 2 To UBound(tbl, 1)
        ky = tbl(i, 1) & "_" & tbl(i, 2) & "_" & tbl(i, 3) & "_" & tbl(i, 4)
        If Not .Exists(ky) Then .Add ky, Empty
    Next
    tbl = Sheets("Sheet2").Range("A1").CurrentRegion.Resize(, 4).Value
    For i = 2 To UBound(tbl, 1)
        ky = tbl(i, 1) & "_" & tbl(i, 2) & "_" & tbl(i, 3) & "_" & tbl(i, 4)
        If .Exists(ky) Then .Remove ky
    Next
    Sheets("Sheet3").Range("A:D").ClearContents
    Sheets("Sheet3").Range("A1:D1").Value = Split("部 課 担当 氏名")
    If .Count Then
        i = 1
        For Each ky In .Keys
            i = i + 1
            Sheets("Sheet3").Range("A" & i).Resize(, 4).Value = Split(ky, "_")
        Next
    End If
End With
End Sub

 まず、要件限定版。
 A列からD列のリストを対象。Sheet2のF列以降を作業域として使用。（もちろん最後はクリアしてある）
 何が限定化というと、Sheet2の有資格者が重複を排除して(XL2003なら)252名までしか対応できない。
 （XL2007以降なら、ほとんど気にしなくてもよくなるけど）
 もし、これでは人数的にダメということなら、処理時間が長くなるけど、Dictionary他、通常コードにする。
 とりあえず試してみて。

 Sub Sample()
    Dim j As Long, y As Long, z As Long

    Application.ScreenUpdating = False

    y = Sheets("Sheet1").Range("A" & Sheets("Sheet1").Rows.Count).End(xlUp).Row

    With Sheets("Sheet2")
        .Columns("E").ClearContents  '作業域
        'Sheet2　有資格者を重複を排除して E列に列挙
        .Columns("D:D").AdvancedFilter Action:=xlFilterCopy, _
            CopyToRange:=.Range("E1"), Unique:=True
        z = .Range("E" & .Rows.Count).End(xlUp).Row
        .Range("F1").Resize(, z - 1).Value = .Range("D1").Value '氏名タイトル

        .Range("F2").Resize(, z - 1).Value = _
            WorksheetFunction.Transpose(.Range("D2").Resize(z - 1).Value)
        For j = 6 To 6 + z - 1 - 1  '作業列 F列から作業列の最終まで
            .Cells(2, j).Value = "<>" & .Cells(2, j).Value
        Next
        'Sheet3への転記
        Sheets("Sheet3").Cells.ClearContents
        Sheets("Sheet1").Range("A1:D" & y).AdvancedFilter Action:=xlFilterCopy, _
            CriteriaRange:=.Range("F1").Resize(2, z - 1), _
            CopyToRange:=Sheets("Sheet3").Range("A1"), Unique:=False
        '作業列のクリア
        .Columns("E").ClearContents
        .Range("F1").Resize(2, z - 1).ClearContents
    End With

    Sheets("Sheet3").Select
    Application.ScreenUpdating = True

 End Sub

 ぶらっと立ち寄り

 お二人ともありがとうございます！
 両方、ちゃんと動作することが確認できました。

 さらに、お願いがあるのですが・・・。
 以下のように仕様を変更したいと思っています。

 Sheet1、sheet2両方に、
 ・Ａ列にNo.（上から1,2,3,…と、データの並びがバラバラになった時にソートする用の数字）
 ・Ｂ列に部データ
 ・Ｃ列に課データ
 ・Ｄ列に担当データ
 ・Ｅ列に氏名コード（社員固有のもの）
 ・Ｆ列に氏名
 ・Ｇ列に年齢
 （sheet2には上記＋Ｈ列に資格名）が入っている時、

 「氏名」ではなく「氏名コード」をキーとして、
 重複しないデータをsheet3へ抽出（sheet3にはNo.～年齢までのデータを表示）
 させるには、どのように変更すれば良いでしょうか・・？
 お二人の回答を参考に、色々いじってみたのですがうまくいきません。。
 分りづらい点がありましたらお聞きください。
 （ぷち）

 いっそのこと、タイトル列の最終を動的に判定して処理するということも必要ならやってもいいけど
 とりあえず、コードの先頭でデータの最終列記号とマッチングしたい列の記号を規定するコードにしてある。
 でも、先にも書いたけど、３列増えたので、XL2003では有資格者が249人までしかサポートしないよ。

 Sub Sample2()
    Dim j As Long, y As Long, z As Long
    Dim myCol As String
    Dim myKey As String
    Dim wCol As Long
    Dim kCol As Long
    Dim dCol As Long

    Application.ScreenUpdating = False

    myCol = "G" '対象データ　G列まで   ★ここで規定
    myKey = "E" 'マッチングキー列　　　★ここで規定

    dCol = Columns(myCol).Column
    wCol = dCol + 1
    kCol = Columns(myKey).Column

    y = Sheets("Sheet1").Range("A" & Sheets("Sheet1").Rows.Count).End(xlUp).Row

    With Sheets("Sheet2")
        .Columns(wCol).ClearContents  '作業域
        'Sheet2　有資格者を重複を排除して 作業列に列挙
        .Columns(myKey).AdvancedFilter Action:=xlFilterCopy, _
            CopyToRange:=.Cells(1, wCol), Unique:=True
        z = .Cells(.Rows.Count, wCol).End(xlUp).Row
        .Cells(1, wCol + 1).Resize(, z - 1).Value = .Range(myKey & "1").Value 'キータイトル
        .Cells(2, wCol + 1).Resize(, z - 1).Value = _
            WorksheetFunction.Transpose(.Range(myKey & "2").Resize(z - 1).Value)
        For j = wCol + 1 To wCol + 1 + z - 1 - 1 '作業列の２列目から作業列の最終まで
            .Cells(2, j).Value = "<>" & .Cells(2, j).Value
        Next
        'Sheet3への転記
        Sheets("Sheet3").Cells.ClearContents
        Sheets("Sheet1").Range("A1:" & myCol & y).AdvancedFilter Action:=xlFilterCopy, _
            CriteriaRange:=.Cells(1, wCol + 1).Resize(2, z - 1), _
            CopyToRange:=Sheets("Sheet3").Range("A1"), Unique:=False
        '作業列のクリア
        .Columns(wCol).ClearContents
        .Cells(1, wCol + 1).Resize(2, z - 1).ClearContents
    End With

    Sheets("Sheet3").Select
    Application.ScreenUpdating = True

 End Sub

 ぶらっと立ち寄り

 検証しておりませんが、いかがでしょうか。(ROUGE)
　
Sub Buchi()
Dim tbl, ky, i As Long, ii As Long, x(1 To 1, 1 To 7)
With CreateObject("Scripting.Dictionary")
    tbl = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 7).Value
    For i = 2 To UBound(tbl, 1)
        ky = tbl(i, 5)
        If Not .Exists(ky) Then
            For ii = 1 To 7
                x(1, ii) = tbl(i, ii)
            Next
            .Add ky, x
        End If
    Next
    tbl = Sheets("Sheet2").Range("A1").CurrentRegion.Resize(, 5).Value
    For i = 2 To UBound(tbl, 1)
        ky = tbl(i, 5)
        If .Exists(ky) Then .Remove ky
    Next
    Sheets("Sheet3").Range("A:G").ClearContents
    Sheets("Sheet3").Range("A1:G1").Value = Split("No. 部 課 担当 氏名コード 氏名 年齢")
    If .Count Then
        i = 1
        For Each ky In .Keys
            i = i + 1
            Sheets("Sheet3").Range("A" & i).Resize(, 7).Value = .Item(ky)
        Next
    End If
End With
End Sub

 お二人とも、有難うございました。
 両方のやり方できちんと動作することが確認できました。
 大変感謝しております。
 今後色々と変更したい部分もありますので、それによってお二人のマクロを参考に
 色々といじってみようと思います。

 （ぷち）

コメント返信：

[ 一覧(最新更新順) ]

[[20110623151753]] 『別シートを比較して重複しないデータを抽出する』（ぷち） ページの最後に飛ぶ

[[20110623151753]]　『別シートを比較して重複しないデータを抽出する』（ぷち）　ページの最後に飛ぶ