質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

87.37%

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

受付中

回答 3

投稿 編集

  • 評価
  • クリップ 0
  • VIEW 250

score 0

前提・実現したいこと

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

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

原本は使えない為、別途作成しました
イメージ説明
イメージ説明
※名前は仮で入れているだけです

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

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

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

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

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

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

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

試したこと

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

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

①シート名が違いますが、別データで試したため気にしないでください。
こちらは単純に前月と当月で片方に居ない人を抽出するマクロとして改変して作りました。
(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

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

質問への追記・修正、ベストアンサー選択の依頼

  • hex309

    2021/10/21 16:00

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

    キャンセル

  • Usirow

    2021/10/21 17:52

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

    キャンセル

回答 3

0

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

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

こんな流れです。

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

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

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

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

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

0

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技術解説

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

0

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

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

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 87.37%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る