[[20150518145205]]　『ある項目をもとに、別シートに反映させたい』（だんご）　ページの最後に飛ぶ

『ある項目をもとに、別シートに反映させたい』（だんご）

 いつもお世話になっております。
 Sheet1の基礎データをもとに、Sheet2に担当別で反映させたいので、ご助力いただけると幸いです。

 Sheet1：シート名「基礎データ」
   A       B         C         D         E         F         G         H         I         J
 1　　　　　　　　　６月１日　６月１日　６月１日　６月１日　６月２日　６月２日　６月２日　６月２日…
 2 取引先　担当課　　納品個数　納品回数　想定時間　担当者　　納品個数　納品回数　想定時間　担当者
 3 Ａ社　　　　３　　　　　４　　　　１　　　　２　阿部　　　　　　３　　　　２　　　　２　鈴木
 4 Ａ社　　　　２　　　　　０　　　　０　　　　０　　　　　　　　　４　　　　１　　　　３　田中
 5 Ａ社　　　　１　　　　　０　　　　０　　　　０　　　　　　　　　２　　　　１　　　　３　阿部
 6 Ｂ社　　　　３　　　　　１　　　　１　　　　１　阿部　　　　　　１　　　　２　　　　１　鈴木
 ：

 上記データをもとに、Sheet2に担当者を基準としたシートを作りたいので、やり方をご教示ください。
 イメージとしては以下のようになります。

 Sheet2：シート名「担当者別」
   A     B         C       D       E         F         G         H       I       J         K         L
 1 名前　日付　　　取引先　担当課　納品個数　納品回数　想定時間　取引先　担当課　納品個数　納品回数　想定時間
 2 阿部　６月１日　Ａ社　　　　３　　　　４　　　　１　　　　２　Ｂ社　　　　３　　　　１　　　　１　　　　１
 3 阿部　６月２日　Ａ社　　　　１　　　　２　　　　１　　　　３
 4 ：
 5 阿部　７月31日
 6 鈴木　６月１日
 7 鈴木　６月２日　Ａ社　　　　３　　　　３　　　　２　　　　２　Ｂ社　　　　３　　　　１　　　　２　　　　１
 　：

 以下、補足です（不要ならすみません）
 ※ 基礎データの縦列はおよそ200行、横列は100列ほどかと思います。
 ※ 担当者は90名ほどです。
 ※ 一日にまわる取引先は、最大で3つです。
 ※ マクロでも関数でも構いません。

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

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

 質問です。

 基礎データ　6月1日の4行目、5行目　担当者空白ですが、これは、その日の実績がないから空白ですね？
 で、これらは、担当者別には対象外として反映させないのですね？
 この実績なしの判定は担当者が空白かどうかで判定していいですか？
 それとも、実績がすべてゼロということを判定しなければいけませんか？

 担当者別　6月1日になぜ鈴木が登場するのですか？

（β） 2015/05/18(月) 17:00

 ↑で質問した件も含めて、要件誤解あるかもしれませんが、ピボットや関数での回答までのつなぎで。
 転記前に並び替えをしていますが、それでも、基礎データの出現順に担当者別に反映する保証はありません。
 並び替えをせず、かつ基礎データの出現順に作表するバージョンも書いてみようと思いますが、とりあえず。

 Sub Test()
    Dim dic As Object
    Dim i As Long
    Dim j As Long
    Dim mx As Long
    Dim w As Variant
    Dim k As Variant
    Dim d As Variant
    Dim v As Variant
    Set dic = CreateObject("Scripting.Dictionary")

    With Sheets("Sheet1").Range("A1").CurrentRegion
        For i = 3 To .Rows.Count
            For j = 3 To .Columns.Count Step 4
                If IsEmpty(.Cells(i, j)) Then Exit For
                If Not IsEmpty(.Cells(i, j + 3)) Then
                    k = .Cells(i, j + 3).Value & vbTab & .Cells(1, j).Value
                    If Not dic.exists(k) Then Set dic(k) = CreateObject("Scripting.Dictionary")
                    dic(k)(dic(k).Count) = Array(.Cells(i, 1).Value, .Cells(i, 2).Value, .Cells(i, j).Value, .Cells(i, j + 1).Value, .Cells(i, j + 2).Value)
                    If dic(k).Count > mx Then mx = dic(k).Count
                End If
            Next
        Next
    End With

    ReDim w(1 To dic.Count, 1 To mx * 5 + 2)

    i = 0
    For Each k In dic
        i = i + 1
        v = Split(k, vbTab)
        w(i, 1) = v(0)
        w(i, 2) = v(1)
        j = 3
        For Each d In dic(k).items
            w(i, j) = d(0)
            w(i, j + 1) = d(1)
            w(i, j + 2) = IIf(d(2) = 0, Empty, d(2))
            w(i, j + 3) = IIf(d(3) = 0, Empty, d(3))
            w(i, j + 4) = IIf(d(4) = 0, Empty, d(4))
            j = j + 5
        Next
    Next

    Application.ScreenUpdating = False

    With Sheets("Sheet2")
        .UsedRange.ClearContents
        .Range("A1:B1").Value = Array("名前", "日付")
        .Range("A2").Resize(UBound(w, 1), UBound(w, 2)).Value = w
        For j = 3 To .Range("A1").CurrentRegion.Columns.Count Step 5
            .Cells(1, j).Resize(, 5).Value = Array("取引先", "担当課", "納品個数", "納品回数", "想定時間")
        Next
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=Columns("A"), Order:=xlAscending
        .Sort.SortFields.Add Key:=Columns("B"), Order:=xlAscending
        .Sort.SetRange .Range("A1").CurrentRegion
        .Sort.Header = xlYes
        .Sort.Apply
        .Select
    End With

 End Sub
（β） 2015/05/18(月) 17:11

 出現順を維持し、かつ並べ替えをしないバージョンです。

 Sub Test2()
    Dim dic As Object
    Dim i As Long
    Dim j As Long
    Dim mxCol As Long
    Dim mxRow As Long
    Dim w As Variant
    Dim k As Variant
    Dim d As Variant
    Dim v As Variant
    Dim nm As Variant

    Set dic = CreateObject("Scripting.Dictionary")

    With Sheets("Sheet1").Range("A1").CurrentRegion
        For i = 3 To .Rows.Count
            For j = 3 To .Columns.Count Step 4
                If IsEmpty(.Cells(i, j)) Then Exit For
                nm = .Cells(i, j + 3).Value
                If Not IsEmpty(nm) Then
                    If Not dic.exists(nm) Then Set dic(nm) = CreateObject("Scripting.Dictionary")
                    k = nm & vbTab & .Cells(1, j).Value
                    If Not dic(nm).exists(k) Then Set dic(nm)(k) = CreateObject("Scripting.Dictionary")
                    mxRow = mxRow + 1
                    dic(nm)(k)(dic(nm)(k).Count) = Array(.Cells(i, 1).Value, .Cells(i, 2).Value, .Cells(i, j).Value, .Cells(i, j + 1).Value, .Cells(i, j + 2).Value)
                    If dic(nm)(k).Count > mxCol Then mxCol = dic(nm)(k).Count
                End If
            Next
        Next
    End With

    ReDim w(1 To mxRow, 1 To mxCol * 5 + 2)

    i = 0
    For Each nm In dic
        For Each k In dic(nm)
                i = i + 1
                v = Split(k, vbTab)
                w(i, 1) = v(0)
                w(i, 2) = v(1)
                j = 3
                For Each d In dic(nm)(k).items
                    w(i, j) = d(0)
                    w(i, j + 1) = d(1)
                    w(i, j + 2) = IIf(d(2) = 0, Empty, d(2))
                    w(i, j + 3) = IIf(d(3) = 0, Empty, d(3))
                    w(i, j + 4) = IIf(d(4) = 0, Empty, d(4))
                    j = j + 5
                Next
        Next
    Next

    Application.ScreenUpdating = False

    With Sheets("Sheet2")
        .UsedRange.ClearContents
        .Range("A1:B1").Value = Array("名前", "日付")
        .Range("A2").Resize(UBound(w, 1), UBound(w, 2)).Value = w
        For j = 3 To .Range("A1").CurrentRegion.Columns.Count Step 5
            .Cells(1, j).Resize(, 5).Value = Array("取引先", "担当課", "納品個数", "納品回数", "想定時間")
        Next
        .Select
    End With

 End Sub

（β） 2015/05/18(月) 18:13

 βさん

 Test1とTest2、どちらも試しました。イメージとほぼ同じものができています。ありがとうございます。
 以下、最初にいただいた質問の答えです。

 >基礎データ　6月1日の4行目、5行目　担当者空白ですが、これは、その日の実績がないから空白ですね？
 → はい。

 >で、これらは、担当者別には対象外として反映させないのですね？
 → そうです。

 >この実績なしの判定は担当者が空白かどうかで判定していいですか？
 >それとも、実績がすべてゼロということを判定しなければいけませんか？
 → 担当者欄が空白かどうかで判定してくださって構いません。

 >担当者別　6月1日になぜ鈴木が登場するのですか？
 → 鈴木に対して、6月1日は勤務がないということを明確に示すためです。

 よろしくお願いします。

（だんご） 2015/05/18(月) 18:56

 >>鈴木に対して、6月1日は勤務がないということを明確に示すためです。

 これ以外は、Test、Test2　ともにＯＫだと思います。

 う～ん・・・やっかいですね。ということは、ある日、全員が勤務無ということもありうる？
 かつ、もし、基礎データシートに記載の日で、一日も登場しなかった人（長期休暇等）は
 反映しようがないですね。

 これは、かなりヘビーな予感（？）
 ちょっとやってみますが、別途、担当者一覧のようなものが必要になるかもです。

（β） 2015/05/18(月) 19:08

 やってみると、そんなにヘビーでもなかったです。（と、思う）
 お試しください。

 Sub Test3()
    Dim dic As Object
    Dim i As Long
    Dim j As Long
    Dim mxCol As Long
    Dim mxRow As Long
    Dim w As Variant
    Dim k As Variant
    Dim d As Variant
    Dim v As Variant
    Dim nm As Variant
    Dim x As Long

    Set dic = CreateObject("Scripting.Dictionary")

    With Sheets("Sheet1").Range("A1").CurrentRegion
        'Phase-1 人別、日別の枠の組み立て
        For i = 3 To .Rows.Count
            For j = 3 To .Columns.Count Step 4
                If IsEmpty(.Cells(i, j)) Then Exit For
                nm = .Cells(i, j + 3).Value
                If Not IsEmpty(nm) Then
                    If Not dic.exists(nm) Then Set dic(nm) = CreateObject("Scripting.Dictionary")
                    For x = 3 To .Columns.Columns.Count Step 4
                        k = nm & vbTab & .Cells(1, x).Value
                        Set dic(nm)(k) = CreateObject("Scripting.Dictionary")
                        mxRow = mxRow + 1
                    Next
                End If
            Next
        Next

        'Phase-2 データの格納
        For i = 3 To .Rows.Count
            For j = 3 To .Columns.Count Step 4
                If IsEmpty(.Cells(i, j)) Then Exit For
                nm = .Cells(i, j + 3).Value
                If Not IsEmpty(nm) Then
                    k = nm & vbTab & .Cells(1, j).Value
                    dic(nm)(k)(dic(nm)(k).Count) = Array(.Cells(i, 1).Value, .Cells(i, 2).Value, .Cells(i, j).Value, .Cells(i, j + 1).Value, .Cells(i, j + 2).Value)
                    If dic(nm)(k).Count > mxCol Then mxCol = dic(nm)(k).Count
                End If
            Next
        Next

    End With

    ReDim w(1 To mxRow, 1 To mxCol * 5 + 2)

    i = 0
    For Each nm In dic
        For Each k In dic(nm)
                i = i + 1
                v = Split(k, vbTab)
                w(i, 1) = v(0)
                w(i, 2) = v(1)
                j = 3
                For Each d In dic(nm)(k).items
                    w(i, j) = d(0)
                    w(i, j + 1) = d(1)
                    w(i, j + 2) = IIf(d(2) = 0, Empty, d(2))
                    w(i, j + 3) = IIf(d(3) = 0, Empty, d(3))
                    w(i, j + 4) = IIf(d(4) = 0, Empty, d(4))
                    j = j + 5
                Next
        Next
    Next

    Application.ScreenUpdating = False

    With Sheets("Sheet2")
        .UsedRange.ClearContents
        .Range("A1:B1").Value = Array("名前", "日付")
        .Range("A2").Resize(UBound(w, 1), UBound(w, 2)).Value = w
        For j = 3 To .Range("A1").CurrentRegion.Columns.Count Step 5
            .Cells(1, j).Resize(, 5).Value = Array("取引先", "担当課", "納品個数", "納品回数", "想定時間")
        Next
        .Select
    End With

 End Sub

（β） 2015/05/18(月) 20:22

 βさん

 夜にもかかわらずご回答くださり、ありがとうございました。
 せっかく作っていただいたのに大変申し訳ないのですが、本日中にTest3を試すのが、もしかしたら難しいかもしれません。すみません。
 明日には必ずお返事いたします。

 なおご質問いただいた件ですが、以下の通りです。
 >ある日、全員が勤務無ということもありうる？
 → はい。おっしゃる通り一斉休日はありますが、Sheet1の1列めにはその日付は載せない予定です。

 >基礎データシートに記載の日で、一日も登場しなかった人（長期休暇等）は反映しようがないですね。
 → 長期休暇者のことまでご考慮いただき、ありがとうございます。
 　一日も勤務しない者は何名かおりますが、長期休職ですので、特に考えなくて良いかと思っております。
 　（最初の書き込みを正確に言うと、実勤務者約90名＋休職者数名という感じです）

 以上です。よろしくお願いいたします。

（だんご） 2015/05/19(火) 17:15

 βさん

 お待たせしてすみません、先ほど試しました。

 >>>鈴木に対して、6月1日は勤務がないということを明確に示すためです。
 これもクリアされていて、感動いたしました。

 何時間も考えてくださったかと思うと、感謝に堪えません。
 本当にありがとうございました。

（だんご） 2015/05/20(水) 11:20

コメント返信：

[ 一覧(最新更新順) ]

[[20150518145205]] 『ある項目をもとに、別シートに反映させたい』（だんご） ページの最後に飛ぶ

[[20150518145205]]　『ある項目をもとに、別シートに反映させたい』（だんご）　ページの最後に飛ぶ