Excel VBA 比較表の作成及び抽出について

Question

前提・実現したいこと

仕事の関係でExcel自体はよく利用するのですが、関数ではなくVBAを使わないと難しそうな抽出が出てきたため質問します。

①利用者名簿リスト前月
②利用者名簿リスト今月
上記の比較表をVBAで抽出・並べ替えを行おうとしています。

原本は使えない為、別途作成しました


※名前は仮で入れているだけです

実際は毎月名簿を差し替えるため、前月と当月シートには手作業で利用者名簿を載せる予定です。
上記のような名簿二つから、所属別にシートを分けて並び替えを行おうとしています。

所属毎にシートを作成して、左側に前月・右側を今月として抽出します。（マクロの中でシートを作成するようにしようと考えています）
所属はランダムではなく、作成パターンは決まっています。

その際に、前月と今月で利用している人が比較してわかるようにしたいのです。
Filter関数で所属別に整理した時は自動的に空白が詰められてしまい、うまく出来ませんでした。

・「前月利用者１０」が「今月利用者にいない」場合「今月の部分に空欄を作る」
・「今月利用者１３」が「先月利用者にいない」場合「先月の部分に空欄を作る」
・「前月利用者」と「今月利用者」が一致した人がいる場合、隣に並べる

これきりになると思ったため、マクロの切り貼りでうまいことできないかと色々と探したのですが・・・
まったく見つからず、こちらに質問させていただきました。

有識者の方の知識をお借りできればと思います。

よろしくお願いいたします。

試したこと

シート内から特定条件を指定して別シートに抽出する
（結局意味ありませんでした）

追記：使用したマクロがあった方が良いとアドバイスをいただきましたので、下記に示します。

①シート名が違いますが、別データで試したため気にしないでください。
こちらは単純に前月と当月で片方に居ない人を抽出するマクロとして改変して作りました。
(ttps://excel.kuuneruch.com/sabun-extra/)

Public Sub MainProc()
Dim shtMain As Worksheet
Dim motoName As String
Dim sakiName As String
Dim shtMoto As Worksheet
Dim shtSaki As Worksheet
Dim shtSabun As Worksheet
Dim lastRowMoto As Long
Dim lastRowSaki As Long
Dim lastCol As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim blnSame As Boolean
Dim blnExist As Boolean
Dim nowRow As Long

Set shtMain = ThisWorkbook.Sheets("メイン")
motoName = shtMain.Range("A2")
sakiName = shtMain.Range("B2")
Set shtMoto = ThisWorkbook.Sheets(motoName)
Set shtSaki = ThisWorkbook.Sheets(sakiName)
Set shtSabun = ThisWorkbook.Sheets("比較")
lastRowMoto = shtMoto.Cells(shtMoto.Rows.Count, 1).End(xlUp).Row
lastCol = shtMoto.Cells(1, shtMoto.Columns.Count).End(xlToLeft).Column
lastRowSaki = shtSaki.Cells(shtSaki.Rows.Count, 1).End(xlUp).Row
shtSabun.Cells.Clear
shtMoto.Range(shtMoto.Cells(1, 1), shtMoto.Cells(1, lastCol)).Copy (shtSabun.Cells(1, 1)) 
nowRow = 1
For i = 2 To lastRowMoto
    blnExist = False
    For j = 2 To lastRowSaki
        blnSame = True
        For k = 1 To lastCol
            If shtMoto.Cells(i, k) <> shtSaki.Cells(j, k) Then
                blnSame = False
                Exit For
            End If
        Next    
        If blnSame = True Then
            blnExist = True
            Exit For
        End If
    Next
    If blnExist = False Then
        nowRow = nowRow + 1
        shtMoto.Range(shtMoto.Cells(i, 1), shtMoto.Cells(i, lastCol)).Copy (shtSabun.Cells(nowRow, 1))
    End If
Next
MsgBox "完了"

End Sub

②こちらは参考にして作ったのですが、うまく出来ずに丸ごと消してしまったためもともと参考にしていたサイトの物を載せます。
(ttp://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/prog/prog04.html)

Sub prog4_1()
Dim myFld As String, myCri As String
Dim myRow As Long
myFld = InputBox("検索は何列目ですか?")
myCri = InputBox("検索する語句を入力しなさい")
'オートフィルタでデータを抽出する
Worksheets("データ").Range("A1").AutoFilter Field:=myFld, Criteria1:=myCri
’抽出データの最終行を求める
myRow = Worksheets("データ").Range("A" & Rows.Count).End(xlUp).Row
'抽出先をクリアする
Worksheets("抽出").Range("A:E").ClearContents
'抽出データをコピーして貼り付け
Worksheets("データ").Range("A1:E" & myRow).Copy Worksheets("抽出").Range("A1")
'オートフィルタを解除
Worksheets("データ").Range("A1").AutoFilter
'抽出先シートをアクティブにしてA1セルを選択する
Worksheets("抽出").Activate
Range("A1").Select
End Sub

Comments

[hex309]

現状のコードを提示されたほうが回答が付きやすいかと

[Usirow]

所属はランダムではなくパターンとのことですが、予め先月当月含めた全員分の名簿を作成することはできないのでしょうか？
可能であるなら、別々の名簿を突き合せるよりも、全員分の名簿に先月フラグ当月フラグなどを付けた方が簡単そうに見えます。

Answer 1

たとえばこんな感じでどうでしょうか。

Sub sample()
    Dim zen As Worksheet
    Dim tou As Worksheet
    Dim dest As Worksheet
    
    Set zen = Worksheets("前月")
    Set tou = Worksheets("当月")
    
    Dim i, r, n
    With zen.UsedRange
        For i = 2 To .Rows.Count
            n = .Cells(i, 1).Value                                      '名前
            Set dest = Worksheets(.Cells(i, 3).Value)                   '所属（転記先シート）
            r = dest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1 '転記先の行番号
            dest.Range("A" & r).Value = n                               'ソート用
            .Rows(i).Copy dest.Cells(r, 2)
            dest.Sort.Apply
        Next
    End With
    
    With tou.UsedRange
        For i = 2 To .Rows.Count
            n = .Cells(i, 1).Value
            Set dest = Worksheets(.Cells(i, 3).Value)
            If WorksheetFunction.CountIf(dest.Columns(1), n) = 0 Then
                r = dest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
            Else
                r = WorksheetFunction.Match(n, dest.Columns(1), 0)    '既にある場合はその行
            End If
            dest.Range("A" & r).Value = n
            .Rows(i).Copy dest.Cells(r, 10)
            dest.Sort.Apply
        Next
    End With
    
    For Each dest In Worksheets                            'ソート用のワーク列をクリア
        If dest.Name <> zen.Name And dest.Name <> tou.Name Then dest.Columns(1).ClearContents
    Next
End Sub

Answer 2

Dictionaryオブジェクトにデータを格納して、それをシートに出力するという方法で作ってみました。

名前、ID、所属を結合(Join)したものをKeyにして、
前月の(名前、ID、所属)の配列と当月の(名前、ID、所属)の配列をさらに一つの配列まとめてItemに格納します。

Public Sub MainProcByDictionary()
'Microsoft Scripting Runtime 参照設定必須
    Dim d1 As New Dictionary    '所属①格納用
    Dim d2 As New Dictionary    '所属②格納用

    Dim ary, i As Long, ary2
    ary = Worksheets("前月").Range("B3").CurrentRegion.Resize(, 3).Value
    For i = 1 To UBound(ary)
        ary2 = Array(ary(i, 1), ary(i, 2), ary(i, 3))
        Select Case ary2(2)
        Case "所属①"
            d1(Join(ary2)) = Array(ary2, Array(""))
        Case "所属②"
            d2(Join(ary2)) = Array(ary2, Array(""))
        Case "所属"
            d1(Join(ary2)) = Array(ary2, ary2)
            d2(Join(ary2)) = Array(ary2, ary2)
        End Select
    Next

    ary = Worksheets("当月").Range("B3").CurrentRegion.Resize(, 3).Value
    For i = 1 To UBound(ary)
        ary2 = Array(ary(i, 1), ary(i, 2), ary(i, 3))
        Select Case ary2(2)
        Case "所属①"
            If d1.Exists(Join(ary2)) Then
                d1(Join(ary2)) = Array(d1(Join(ary2))(0), ary2)
            Else
                d1(Join(ary2)) = Array(Array(""), ary2)
            End If
        Case "所属②"
            If d2.Exists(Join(ary2)) Then
                d2(Join(ary2)) = Array(d2(Join(ary2))(0), ary2)
            Else
                d2(Join(ary2)) = Array(Array(""), ary2)
            End If
        End Select
    Next

    Dim Itm
    With Worksheets("所属①")
        i = 3
        For Each Itm In d1.Items
            .Cells(i, "B").Resize(, 3).Value = Itm(0)
            .Cells(i, "J").Resize(, 3).Value = Itm(1)
            i = i + 1
        Next
    End With
    With Worksheets("所属②")
        i = 3
        For Each Itm In d2.Items
            .Cells(i, "B").Resize(, 3).Value = Itm(0)
            .Cells(i, "J").Resize(, 3).Value = Itm(1)
            i = i + 1
        Next
    End With
End Sub

Dictionaryについては検索すれば解説ページはいろいろ見つかりますので研究してみてください。
下記のページは比較的簡潔に使い方を説明してます。

Dictionary（ディクショナリー）連想配列の使い方について｜VBA技術解説

Answer 3

こんにちは。
前月／当月を比較しながら「この行にはどの人が入るか」を考えていくと
ちょっと処理が複雑になるので、Excelの機能を利用して先に
「この行はだれか」を決めてしまってから、データを移すと楽じゃないかと思います。

１．前月シートの内容と当月シートの内容が縦に並ぶように貼り付けた作業領域を作る
２．「フィルタオプションの設定」(VBAでいうところのAdvancedFilter)を使用して
作業域から、当該所属の人の名前を一意に抽出して、各々の方がどの行に来るかを
割り当てる。
３．割り当てた領域に前月／当月シートから各々データを貼り付ける。

こんな流れです。

例えばご提示されている前月／当月シートから所属①のシートに貼り付けるサンプルだと

Public Sub MainProc()
Dim shtShozoku      As Worksheet                '貼付け先の所属シート
Dim rowCount        As Long                     '当該所属の（前月＋今月）に登場する人の数
Dim rowZengetsu     As Long                     '前月のシートの最終行
Dim rowTogetsu      As Long                     '当月のシートの最終行
    
    Set shtShozoku = ThisWorkbook.Worksheets("所属①")
    
    rowZengetsu = ThisWorkbook.Worksheets("前月").Range("B3").End(xlDown).Row   '前月シートの最終行数取得
    ThisWorkbook.Worksheets("前月").Range("B3").CurrentRegion.Copy              '前月シートの内容を所属シートの空エリアにコピー
    shtShozoku.Range("R3").PasteSpecial Paste:=xlPasteValues
    rowTogetsu = ThisWorkbook.Worksheets("当月").Range("B3").End(xlDown).Row    '当月シートの最終行取得
    ThisWorkbook.Worksheets("当月").Range("B3").CurrentRegion.Copy              '当月シートの内容を、先にコピーした前月の下にコピー
    shtShozoku.Range("R3").End(xlDown).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
        
    shtShozoku.Range("Z3").Value = "所属"                                       'コピーしたデータから所属①の人のみ抽出するための
    shtShozoku.Range("Z4").Value = "所属①"                                     'フィルタ条件を指定
    
    'フィルタ条件にて、前月＋当月のデータから所属①の人の名前／ID／所属　を一意になるように抽出（Unique:=True)
    Intersect(shtShozoku.Range("R3").CurrentRegion, shtShozoku.Range("R:T")).AdvancedFilter Action:=xlFilterCopy, _
                                                        Criteriarange:=shtShozoku.Range("Z3:Z4"), _
                                                        CopyTORange:=shtShozoku.Range("AB3"), Unique:=True
    
    rowCount = shtShozoku.Range("AB3").CurrentRegion.Rows.Count - 1             '抽出された人数を把握
    
    '一意に抽出された所属①の方の名前がAB列に出来上がっているはずなので、名前をキーにしてVLOOKUPにて前月／当月シートから情報を引っ張る
    shtShozoku.Range("B4:H" & Format(rowCount + 3)).FormulaR1C1 = "=IF(IFERROR(VLOOKUP(RC28,前月!R3C2:R" & Format(rowZengetsu) & _
                              "C8,Column()-1,False),"""")="""","""",IFERROR(VLOOKUP(RC28,前月!R3C2:R" & Format(rowZengetsu) & "C8,Column()-1,False),""""))"
    
    shtShozoku.Range("J4:P" & Format(rowCount + 3)).FormulaR1C1 = "=IF(IFERROR(VLOOKUP(RC28,当月!R3C2:R" & Format(rowTogetsu) & _
                              "C8,Column()-9,False),"""")="""","""",IFERROR(VLOOKUP(RC28,当月!R3C2:R" & Format(rowTogetsu) & "C8,Column()-9,False),""""))"
    '値コピーして式を値に変更
    With shtShozoku.Range("B4:P" & Format(rowCount + 3))
        .Copy
        .PasteSpecial Paste:=xlPasteValues
    End With
    '作業用にごちゃごちゃ使ったところを消す
    shtShozoku.Range("R:AH").Delete
    
End Sub

のような感じです。サンプルとしては貼り付け先の所属シートの空いてる部分を
作業領域に使いましたが、作業用の別シートを作ってもいいかもしれないですね。
（複数所属の対応になるでしょうから、前月＋当月の全体集合データは最初に１回
作るだけにした方が効率いいですね）

また、状況によっては抽出後に並び替えの考慮が必要になるかもしれません。