[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『ある項目をもとに、別シートに反映させたい』(だんご)
いつもお世話になっております。 Sheet1の基礎データをもとに、Sheet2に担当別で反映させたいので、ご助力いただけると幸いです。
Sheet1:シート名「基礎データ」 A B C D E F G H I J 1 6月1日 6月1日 6月1日 6月1日 6月2日 6月2日 6月2日 6月2日… 2 取引先 担当課 納品個数 納品回数 想定時間 担当者 納品個数 納品回数 想定時間 担当者 3 A社 3 4 1 2 阿部 3 2 2 鈴木 4 A社 2 0 0 0 4 1 3 田中 5 A社 1 0 0 0 2 1 3 阿部 6 B社 3 1 1 1 阿部 1 2 1 鈴木 :
上記データをもとに、Sheet2に担当者を基準としたシートを作りたいので、やり方をご教示ください。 イメージとしては以下のようになります。
Sheet2:シート名「担当者別」 A B C D E F G H I J K L 1 名前 日付 取引先 担当課 納品個数 納品回数 想定時間 取引先 担当課 納品個数 納品回数 想定時間 2 阿部 6月1日 A社 3 4 1 2 B社 3 1 1 1 3 阿部 6月2日 A社 1 2 1 3 4 : 5 阿部 7月31日 6 鈴木 6月1日 7 鈴木 6月2日 A社 3 3 2 2 B社 3 1 2 1 :
以下、補足です(不要ならすみません) ※ 基礎データの縦列はおよそ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 ともにOKだと思います。
う〜ん・・・やっかいですね。ということは、ある日、全員が勤務無ということもありうる? かつ、もし、基礎データシートに記載の日で、一日も登場しなかった人(長期休暇等)は 反映しようがないですね。
これは、かなりヘビーな予感(?) ちょっとやってみますが、別途、担当者一覧のようなものが必要になるかもです。
(β) 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
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.