エクセルの学校：エクセル質問ボード[[20260305102809]]

エクセル	の学校
8.一覧	9.HOME
1.Top	2.Last

[[20260305102809]]

[ 初めての方へ | 一覧(最新更新順) |

| | 全文検索 | 過去ログ | エクセルの学校HOME ]

『担当者の抽出』（コウケイ）

毎月、業者別に担当者を抽出して別シートに張り付けているのですが、効率が悪くsheet1のデータをsheet2に抽出して貼り付けることができないでしょうか、よろしくお願いいたします。 sheet1 ⇒ sheet2

  A　　　　B                    A　　　　B 
業者名　担当者名             業者名　担当者名
業者a　　担当?@               業者a 　担当?@   
業者a    担当?A                       担当?A
業者b    担当１                       担当?B
業者c    担当A                業者b   担当１
業者b    担当2                        担当2
業者a    担当?A               業者c   担当A
業者c    担当B                        担当B
業者a    担当?B                       担当C

sheet1の業者名は毎月変わりませんが、担当者が、毎月変わり人数も変動し最大10名ほどになります。 sheet2の業者名は固定されており業者間に10行の間隔を開けてありますので、マクロを実行してセルB3より下にsheet1のB列より各業者の担当者を抽出して自動で貼り付けることができないでしょうか、よろしくご教授お願い致します。

＜使用 Excel：Excel2016、使用 OS：Windows11 ＞

Sub 業者別担当者抽出()

    Dim wsSrc As Worksheet '元データ：sheet1
    Dim wsDst As Worksheet '出力先：sheet2
    Dim lastRowSrc As Long
    Dim lastRowDst As Long
    Dim r As Long
    Dim vendor As String
    Dim pasteRow As Long
    Dim findRow As Long

    Set wsSrc = ThisWorkbook.Worksheets("Sheet1") '←元データシート名
    Set wsDst = ThisWorkbook.Worksheets("Sheet2") '←出力シート名

    ' 元データの最終行（A列基準）
    lastRowSrc = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row

    ' 出力先の担当者リストをクリア（B3以降）
    lastRowDst = wsDst.Cells(wsDst.Rows.Count, "B").End(xlUp).Row
    If lastRowDst >= 3 Then
        wsDst.Range("B3:B" & lastRowDst).ClearContents
    End If

    ' sheet2 の A列にある各業者名ごとに担当者を抽出
    r = 2 '業者名の一覧が A2 から下に並んでいる前提（必要なら変更）
    Do While wsDst.Cells(r, "A").Value <> ""

        vendor = wsDst.Cells(r, "A").Value
        pasteRow = 3 '各業者の貼り付け開始行（B3）にリセット

        ' 同じ業者名が sheet2 に複数行ある場合は、その一番下に貼るようにしたいなら、
        ' ここで pasteRow を調整する：
        Do While wsDst.Cells(pasteRow, "A").Value = vendor
            pasteRow = pasteRow + 1
        Loop

        ' sheet1 から該当業者を抽出
        For findRow = 2 To lastRowSrc '1行目は見出し想定
            If wsSrc.Cells(findRow, "A").Value = vendor Then
                wsDst.Cells(pasteRow, "A").Value = vendor
                wsDst.Cells(pasteRow, "B").Value = wsSrc.Cells(findRow, "B").Value
                pasteRow = pasteRow + 1
            End If
        Next findRow

        r = r + 1
    Loop

    MsgBox "抽出が完了しました。"

End Sub

（稚拙） 2026/03/05(木) 11:47:40

 マクロが希望とのことですが、関数で抽出する案です。（無用でしたら無視してください。）

 Sheet2
 A3、A13、A23に業者名があるものとして

 B3: =IFERROR(INDEX(Sheet1!B:B,AGGREGATE(15,6,ROW(Sheet1!$A:$A)/(Sheet1!$A:$A=$A$3),ROW(A1))),"")
 B12までフィル                                                                         ^^^^

 B13: =IFERROR(INDEX(Sheet1!B:B,AGGREGATE(15,6,ROW(Sheet1!$A:$A)/(Sheet1!$A:$A=$A$13),ROW(A1))),"")
 B22までフィル                                                                           ^^^^

 ---線部分のROW(A1)は、条件に合う担当者を上から順に抽出するためのものですので、B4ではA2、B5ではA3、
 になります。業者名が変わるB13にはなた、A1を入力してください。

（jjj） 2026/03/05(木) 12:07:20

 B13にはなた、　→　B13にはまた、
（jjj） 2026/03/05(木) 12:15:15

稚拙さん、jjjさん早速のご返答ありがとうございます。頂戴した、内容を参考に改良させていただきます。わからないことが発生しましたら、再度質問させていただきますので、その時はよろしくお願いいたします。（コウケイ） 2026/03/05(木) 13:29:26

[ 一覧(最新更新順) |

]

キーボードヒント：[Home]または[Fn+Home]キーで一番上へ戻ります