[[20160817151432]]　『担当者の抽出』（おじさん）　ページの最後に飛ぶ

『担当者の抽出』（おじさん）

この前は良いアドバイスをいただきありがとうございました。
また、質問させていただきます。よろしくお願いいたします。

Sheet1 (データ)　月末に締めたデータを前月の後に張り付けています。

   A ・・・・   O         P
1  月　　　　チーム名　担当者名
2

Sheet2 (集計表)

      A        B       C 
 1 6月度　⇒　セルA1(セルの書式設定 #"月度")
 2
 3
 4 チーム名　担当者
 5　チーム１
  (次のチーム名まで10行確保)

15　チーム２

  (次のチーム名まで10行確保)
・
・
・
Sheet1に毎月の売上データを貼り付け、Sheet2で各チームの担当者の実績を出しています。
チーム名は年間通じて変更がないのですが、そのチームごとの担当者が固定されていなく、月ごとに変動しているため、Sheet2の担当者名をその月度ごとに抽出して入力または値で張り付けています。
それが結構大変なため、Sheet2のA1に月数を入力すればチームごとにその月に稼働した担当者が重複せず抽出され、各チーム名の1行下のB列から下に自動で張り付けることができないでしょうか。
皆様よろしくお願いいたします。

＜使用 Excel：Excel2010、使用 OS：Windows10 ＞

 回答ではなく　交通整理です。

 >>その月に稼働した担当者が重複せず抽出

 Sheet1 の状態ですが、たとえば 7月 チーム1 田中　というデータが複数あるのでしょうか？
 それとも、7月 チーム1 田中　は　１行だけなのでしょうか？

 >>各チーム名の1行下のB列から下に自動で張り付けることができないでしょうか

 ・Sheet2 のチーム名は、あらかじめ記載されていて、マッチングして転記するのでしょうか？
 　それとも、Sheet2に記載されている内容は無視して（消して）Sheet1 から　該当のチーム名と担当者を列挙するのでしょうか？

 ・↑がいずれかにもよりますが、5行目から始まるとして、必ず月当り1チーム10行ずつですか？
 　それより多い場合は無視？それより少なくても、間に空白をおいて、10行ずつ？

 >>各チーム名の1行下のB列から下

 具体的に教えてください。たとえば チーム1 の最初の担当者名は　B5　ですか？　B6 ですか？
 チーム2 の最初の担当者は　B15 ですか？ B16 ですか？

 >>Sheet2のA1に月数を入力すれば・・・・自動で張り付けることができないでしょうか。

 希望する処理は　関数処理ですか？　マクロ処理ですか？

（β） 2016/08/17(水) 16:19

βさんありがとうございます。

 >>その月に稼働した担当者が重複せず抽出

１ヶ月に複数日稼働してる月や他の現場にいるためチームを離れている月もあるため、現在格闘付きのチームでフィルターをかけ担当者をいったん全行コピーし他のSheetに張り付けた後重複データを削除して残ったメンバーをコピーして、集計表の該当するチームの担当者列に値で張り付けています。
その月の最大メンバー数が９名の為予備１行を含め１０行のスペースを空けております。

また、担当者名を貼り付けた行のC列からH列までB列に入力されたメンバー名を基にSheet1のデータから関数で集計しておりますので、先所できません。

 >>各チーム名の1行下のB列から下

Sheet2のチーム１の最初の担当者名は　B6　で、チーム２の最初の担当者は　B16　です。

Sheet2のA1に月数を入力すれば・・・・自動で張り付けることができないでしょうか。

できればマクロで、月数を入力後ボタンを押して実行させたいです。

追伸、チーム数は通常１７チームですが、できれば余裕を見て２０チームです。メンバーも１０名を超えることはないのですが、増えた時の対処するためのやり方もご教授お願いできますでしょうか。

よろしくお願いいたします。
（おじさん） 2016/08/17(水) 16:58

昨日、（β）さんからの問い合わせの返答文で、誤変換等がありましたので、再送信いたします。
大変申し訳ございませんでした。

その月に稼働した担当者が重複せず抽出について

１ヶ月に複数日稼働してる月や他の現場にいるためチームを離れている月もあるため、現在該当月のチームでフィルターをかけ担当者をいったん全行コピーし他のSheetに張り付けた後重複データを削除して残ったメンバーをコピーして、集計表の該当するチームの担当者列に値で張り付けています。
その月の最大メンバー数が９名の為予備１行を含め１０行のスペースを空けております。

また、担当者名を貼り付けた行のC列からH列までB列に入力されたメンバー名を基にSheet1のデータから関数で集計しておりますので、削除して上書きすることはできません。

各チーム名の1行目のB列から下について

Sheet2のチーム１の最初の担当者名は　B6　で、チーム２の最初の担当者は　B16　です。

Sheet2のA1に月数を入力すれば・・・・自動で張り付けることができないでしょうか。

できればマクロで、月数を入力後ボタンを押して実行させたいです。

更新するときは、内容をよく確認いたしますので、よろしくお願いいたします。

（おじさん） 2016/08/18(木) 13:48

＞その月の最大メンバー数が９名の為予備１行を含め１０行
＞チーム１の最初の担当者名は　B6　で、チーム２の最初の担当者は　B16

B6からB14がチーム１の担当者欄だとすると、９行ですが？

（マナ） 2016/08/18(木) 19:46

マナさん、ご指摘ありがとうございます。

ご指摘通り間違っていましたので、Sheet2の　４行目からは以下の通りです。

      A       B      C       D      E      F      G      H     I      
 4 チーム名　担当　総売上　項目1　項目2　項目3　項目4　項目5　項目6
 5 チーム1　　　　(各項目ごとにチーム合計表示)
 6            a
 7            b
　・
　・
　・
16 チーム２
17           aa
18           ab

 上記のように各チームの担当者名が入るセルは最初が B6でその次のチーム２担当者名が入るセルが、 B17と行間が１１でした。大変申し訳ございませんでした。
良きアドバイスをお願いいたします。
（おじさん） 2016/08/19(金) 09:36

シート２のA1の横にボタンをおいて、下記マクロを登録

 Option Explicit

 Sub test()
    Dim dic As Object
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim m As Long
    Dim i As Long
    Dim t As String, p As String
    Dim c As Range

    Set dic = CreateObject("scripting.dictionary")

    Set ws1 = Worksheets("Sheet1")  'データシート
    Set ws2 = ActiveSheet
    m = ws2.Range("A1").Value    '抽出月

    For i = 2 To ws1.Range("A" & Rows.Count).End(xlUp).Row
        If ws1.Range("A" & i).Value = m Then
            t = ws1.Range("O" & i).Value    'チーム名
            p = ws1.Range("P" & i).Value    '担当者名
            If Not dic.exists(t) Then
                Set dic(t) = CreateObject("system.collections.arraylist")
            End If
            If Not dic(t).contains(p) Then
                dic(t).Add p
            End If
        End If
    Next

    Set c = ws2.Range("A5")                         'データ開始セル
    c.Offset(, 1).Resize(11 * 20).ClearContents     '１１行×２０チーム

    Do
        t = c.Value
        If dic.exists(t) Then
            c.Offset(1, 1).Resize(dic(t).Count).Value = _
                WorksheetFunction.Transpose(dic(t).toarray)
        End If
        Set c = c.Offset(11)    '１１行毎に１チーム
    Loop Until c.Value = ""

 End Sub

（マナ） 2016/08/19(金) 20:54

コードを見なおしていて気付きました。
Dictionaryだけでよかったです。
（ほとんど同じですが）

 Option Explicit

 Sub test2()
    Dim dic As Object
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim m As Long
    Dim i As Long
    Dim t As String, p As String
    Dim c As Range

    Set dic = CreateObject("scripting.dictionary")

    Set ws1 = Worksheets("Sheet1")  'データシート
    Set ws2 = ActiveSheet
    m = ws2.Range("A1").Value    '抽出月

    For i = 2 To ws1.Range("A" & Rows.Count).End(xlUp).Row
        If ws1.Range("A" & i).Value = m Then
            t = ws1.Range("O" & i).Value    'チーム名
            p = ws1.Range("P" & i).Value    '担当者名
            If Not dic.exists(t) Then
                Set dic(t) = CreateObject("scripting.dictionary")
            End If
            dic(t)(p) = Empty
        End If
    Next

    Set c = ws2.Range("A5")                         'データ開始セル
    c.Offset(, 1).Resize(11 * 20).ClearContents     '１１行×２０チーム

    Do
        t = c.Value
        If dic.exists(t) Then
            c.Offset(1, 1).Resize(dic(t).Count).Value = _
                WorksheetFunction.Transpose(dic(t).keys)
        End If
        Set c = c.Offset(11)    '１１行毎に１チーム
    Loop Until c.Value = ""

 End Sub

（マナ） 2016/08/19(金) 23:13

 ほとんどマナさんのコードのパクリですけど、

 >>Sheet2のA1に月数を入力すれば・・・・自動で張り付けることができないでしょうか

 ということなので、Sheet2のシートモジュールに。
 （Sheet2のシートタブを右クリックしてコードの表示を選んででてくるところ）

 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim m As Variant
    Dim t As Variant
    Dim p As Variant
    Dim i As Long
    Dim c As Range

    Application.ScreenUpdating = False

    If Intersect(Range("A1"), Target) Is Nothing Then Exit Sub
    m = Range("A1").Value
    With CreateObject("Scripting.Dictionary")
        For Each c In Sheets("Sheet1").Range("A2", Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp))
            If c.Value = m Then
                t = c.EntireRow.Range("O1").Value
                p = c.EntireRow.Range("P1").Value
                If Not .exists(t) Then Set .Item(t) = CreateObject("Scripting.DIctionary")
                .Item(t)(p) = True
            End If
        Next

        For i = 5 To Range("A" & Rows.Count).End(xlUp).Row Step 11
            Cells(i + 1, "B").Resize(10).ClearContents
            t = Cells(i, "A").Value
            If .exists(t) Then Cells(i + 1, "B").Resize(.Item(t).Count).Value = WorksheetFunction.Transpose(.Item(t).keys)
        Next
    End With

 End Sub

（β） 2016/08/20(土) 00:25

マナさん、βさん、ありがとうございます。
本日、お二人からの記述を参考にマクロで実行させるプログラムが完成しました。
もっともっと勉強して、自身で作成できるよう努力していきます。
本当にありがとうございました。

（おじさん） 2016/08/23(火) 10:50

コメント返信：

[ 一覧(最新更新順) ]

[[20160817151432]] 『担当者の抽出』（おじさん） ページの最後に飛ぶ

[[20160817151432]]　『担当者の抽出』（おじさん）　ページの最後に飛ぶ