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

前提・実現したいこと

仕事の関係で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

hex309

2021/10/21 07:00

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

Usirow

2021/10/21 08:52

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

行動規範の内容に同意します

回答3件

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

VBA
1Sub sample()
2    Dim zen As Worksheet
3    Dim tou As Worksheet
4    Dim dest As Worksheet
5    
6    Set zen = Worksheets("前月")
7    Set tou = Worksheets("当月")
8    
9    Dim i, r, n
10    With zen.UsedRange
11        For i = 2 To .Rows.Count
12            n = .Cells(i, 1).Value                                      '名前
13            Set dest = Worksheets(.Cells(i, 3).Value)                   '所属（転記先シート）
14            r = dest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1 '転記先の行番号
15            dest.Range("A" & r).Value = n                               'ソート用
16            .Rows(i).Copy dest.Cells(r, 2)
17            dest.Sort.Apply
18        Next
19    End With
20    
21    With tou.UsedRange
22        For i = 2 To .Rows.Count
23            n = .Cells(i, 1).Value
24            Set dest = Worksheets(.Cells(i, 3).Value)
25            If WorksheetFunction.CountIf(dest.Columns(1), n) = 0 Then
26                r = dest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
27            Else
28                r = WorksheetFunction.Match(n, dest.Columns(1), 0)    '既にある場合はその行
29            End If
30            dest.Range("A" & r).Value = n
31            .Rows(i).Copy dest.Cells(r, 10)
32            dest.Sort.Apply
33        Next
34    End With
35    
36    For Each dest In Worksheets                            'ソート用のワーク列をクリア
37        If dest.Name <> zen.Name And dest.Name <> tou.Name Then dest.Columns(1).ClearContents
38    Next
39End Sub

投稿2021/10/22 03:01

編集2021/10/22 03:44

jinoji

総合スコア4585

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

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

vba
1Public Sub MainProcByDictionary()
2'Microsoft Scripting Runtime 参照設定必須
3    Dim d1 As New Dictionary    '所属①格納用
4    Dim d2 As New Dictionary    '所属②格納用
5
6    Dim ary, i As Long, ary2
7    ary = Worksheets("前月").Range("B3").CurrentRegion.Resize(, 3).Value
8    For i = 1 To UBound(ary)
9        ary2 = Array(ary(i, 1), ary(i, 2), ary(i, 3))
10        Select Case ary2(2)
11        Case "所属①"
12            d1(Join(ary2)) = Array(ary2, Array(""))
13        Case "所属②"
14            d2(Join(ary2)) = Array(ary2, Array(""))
15        Case "所属"
16            d1(Join(ary2)) = Array(ary2, ary2)
17            d2(Join(ary2)) = Array(ary2, ary2)
18        End Select
19    Next
20
21    ary = Worksheets("当月").Range("B3").CurrentRegion.Resize(, 3).Value
22    For i = 1 To UBound(ary)
23        ary2 = Array(ary(i, 1), ary(i, 2), ary(i, 3))
24        Select Case ary2(2)
25        Case "所属①"
26            If d1.Exists(Join(ary2)) Then
27                d1(Join(ary2)) = Array(d1(Join(ary2))(0), ary2)
28            Else
29                d1(Join(ary2)) = Array(Array(""), ary2)
30            End If
31        Case "所属②"
32            If d2.Exists(Join(ary2)) Then
33                d2(Join(ary2)) = Array(d2(Join(ary2))(0), ary2)
34            Else
35                d2(Join(ary2)) = Array(Array(""), ary2)
36            End If
37        End Select
38    Next
39
40    Dim Itm
41    With Worksheets("所属①")
42        i = 3
43        For Each Itm In d1.Items
44            .Cells(i, "B").Resize(, 3).Value = Itm(0)
45            .Cells(i, "J").Resize(, 3).Value = Itm(1)
46            i = i + 1
47        Next
48    End With
49    With Worksheets("所属②")
50        i = 3
51        For Each Itm In d2.Items
52            .Cells(i, "B").Resize(, 3).Value = Itm(0)
53            .Cells(i, "J").Resize(, 3).Value = Itm(1)
54            i = i + 1
55        Next
56    End With
57End Sub

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

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

投稿2021/10/21 18:28

hatena19

総合スコア33715

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

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

こんな流れです。

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

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