[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『年間の集計を横並びに作成する』（右近）
おたずねいたします。
以下のような表1があります。
4月から3月までの名簿がありまして、各月の名簿は基本的に重複していますが、途中の月から新規で追加される名前があります。
人によって、各月1データの場合もありますし、2とか3データの場合もあり、まちまちです。
以下の表では各月の行数は一定にはなっていませんが、実際には一定の行数です。
表1
__A____B__________C______D____E______F____G____H____I
1 4月 山田花子 4/20 3500
2 4月 鈴木次郎 4/23 3800 4/30 2500
3 4月 山本太郎 4/30 3200
・
・
・
25 5月 山田花子 5/ 6 2800
26 5月 鈴木次郎 5/10 3000
27 5月 山本太郎 5/20 2900
・
・
・
7012月
上記表1をもとに以下の表2のように名前別に年間の集計をさせたいのです。
横に配列させたいのです。
もちろん、
表2
__F____ G____ H_____I______J______K______L
1 山田花子 4/20 3500 5/ 6 2800
2 鈴木次郎 4/23 3800 4/30 2500 5/10 3000
3 山本太郎 4/30 3200 5/20 2900
・
・
・
OFFSET関数でやってみましたが、これでは縦にデータがつみあがってしまい、表2のように横に並べていく方法がわかりません。
お力添えのほど、よろしくお願いします。
＜ 使用 Excel：Excel2013、使用 OS：Windows7 ＞
こう云うのはマクロが適しているんですけど、関数じゃないとダメなんですか？
（半平太） 2017/03/26(日) 18:58
各表の各項目が、どの列なのかちょっとわかりにくいですね。
・表1 の 1 4月 山田花子 4/20 3500 これらはどの列ですか？ 4月は A列？ B列？ ・表1 の 4/20 3500 といったデータは、いくつはいるか限定されていますか？ それとも、いくつあるかは、そのデータ次第ですか？
・表2 についても、各列が具体的にどこなのかがわかりにくいです。 1 山田花子 4/20 3500 5/ 6 2800 の各項目は、それぞれどの列ですか？ ・表1 に対する回答次第なんですが、表1 の 4/20 3500 といったデータの個数によっては表1 の最終列がどこかは わからないわけですよね？ であれば、表2 を特定の決められた列から表示するというのは、ちょっとしんどいですね？ ここは、どう考えていますか？
（ β） 2017/03/26(日) 22:04
・表1 の 1 4月 山田花子 4/20 3500 これらはどの列ですか？ 4月は A列？ B列？ →回答）4月はA列、名前はB列、日付はC列、番号はD列です。
・表1 の 4/20 3500 といったデータは、いくつはいるか限定されていますか？ それとも、いくつあるかは、そのデータ次第ですか？ →回答）名前によって様々です。極端に言うと、月に1回の人もあれば、5回の人もいるという感じです。
・表2 についても、各列が具体的にどこなのかがわかりにくいです。 1 山田花子 4/20 3500 5/ 6 2800 の各項目は、それぞれどの列ですか？ →回答）名前はF列、日付はG列、番号はH列・・・・・
・表1 に対する回答次第なんですが、表1 の 4/20 3500 といったデータの個数によっては表1 の最終列がどこかはわからないわけですよね？ →回答）はい。ただ、日付と番号の組合せが6セットあれば足りると考えています。
・であれば、表2 を特定の決められた列から表示するというのは、ちょっとしんどいですね？ ここは、どう考えていますか？ →回答）G列からいければと考えていますが・・・ （右近） 2017/03/27(月) 07:31
>G列からいければと考えていますが・・・
もし、表1 と 表 2 を同じシートに配置すると考えておられるとすれば
>日付と番号の組合せが6セットあれば足りると考えています
6セットあった場合は、表1 のデータは、N列まであることになりますね。 そこに G列から 表2 を配置すると、表1 の一部が 上書きされてしまいますが？
（ β） 2017/03/27(月) 07:38
A B C D E F G ・・・ V W X Y 1 1 2 3 4 5 ・・・ 20 21 22 23 2 4月 山田花子 3500 3 4月 鈴木次郎 3800 （右近） 2017/03/27(月) 07:41
関数処理がご希望のようですから、それは専門家さんにお任せするとして、場つなぎでＶＢＡです。 なお、A列が文字列としての 4月 等のようで、年が気になりますので、展開後の 4/20 等も文字列にしています。
★実際にテストデータを作ってみましたが、このレイアウトも、入力しにくいですねぇ。 （入力のしやすさからいえば、元々のもののほうが、操作者にとって簡単かも）
Sub Samle()
Dim c As Range
Dim r As Range
Dim d As Range
Dim dic As Object
Dim k As Variant
Dim x As Long
Dim w As Variant
Application.ScreenUpdating = False
Set dic = CreateObject("Scripting.Dictionary")
For Each c In Range("B2", Range("B" & Rows.Count).End(xlUp))
If Not dic.exists(c.Value) Then Set dic(c.Value) = CreateObject("System.Collections.ArrayList")
Set r = Nothing
On Error Resume Next
Set r = c.Offset(, 1).Resize(, 31).SpecialCells(xlCellTypeConstants, xlNumbers)
On Error GoTo 0
If Not r Is Nothing Then
For Each d In r
dic(c.Value).Add "'" & Replace(d.EntireRow.Cells(1).Value, "月", "") & "/" & d.EntireColumn.Cells(1).Value
dic(c.Value).Add d.Value
Next
End If
Next
ActiveSheet.UsedRange.Offset(1, 33).ClearContents
Range("AH2").Resize(dic.Count).Value = WorksheetFunction.Transpose(dic.keys)
x = 2
For Each k In dic
w = dic(k).toarray
Cells(x, "AI").Resize(, UBound(w) + 1).Value = w
x = x + 1
Next
End Sub
（ β） 2017/03/27(月) 09:13
AK列～BD列の4行目以降にデータが入ります。その詳細は以下のとおりです。
___C_________AK______AL______AM______AN・・・・BC______BD
3 名前 日付1 番号1 日付2 番号2 日付10 番号10
4 山田 4/ 1 2800 4/15 3200
5 鈴木 4/ 5 2900 4/20 2700
・
・
・
20 山田 5/ 6 3000 5/29 2500
・
・
・
上記を同一シートのDW列の4行以降に以下のように並び替えさせられたらと思います。
例えば、山田さんの4月から3月までのデータを一つの行に集約したいのです。
__DW_________DX______DY______DZ______EA________EB_______EC_______ED・・・・・
日付1 番号1 日付2 番号2 日付3 番号3 日付4 番号4 4 4/ 1 2800 4/15 3200 5/ 6 3000 5/29 2500
___
（右近） 2017/03/28(火) 12:52
>読込みのマークが長時間出てしまい、
こちらで想定したレイアウトや、その中の値が実際のものと異なるんでしょうね。
いずれにしても、βは関数超苦手ですので、専門家さんの回答をお待ちください。
（β） 2017/03/29(水) 08:24
＞今一度お尋ねですが、これを関数で導くことは可能でしょうか？
当初のレスで書きましたが、関数での処理には向いていません。
一つのセルに結果を出すのに、膨大な範囲を何度も見に行かなければならないからです。
やってやれないこともないと言う代物です。私は、やる気が起きません。
※マクロ使用が職場で禁止されていると言う様な事情があれば別です。 そう書けば、関数専門家さんからレスが付くと思います。
最終的なレイアウトが下図の通りだとした場合、お節介ながら それに合わせて βさんのプログラム を修正すれば後記の通りです。
TO：βさん
大変勉強になりました。m(__)m
<サンプルおよび結果図> 行 ____C____ _D_ _AJ_ ___AK___ _AL_ ___AM___ _AN_ __AO__ _AP_ ___DW___ ____DX____ _DY_ ____DZ____ _EA_ ____EB____ _EC_ ___ED___ _EE_ ___EF___ _EG_ 3 名前 日付 4 山田花子 4月20日 3500 山田花子 2017/4/20 3500 2017/5/6 2800 5 鈴木次郎 4月23日 3800 4月30日 2500 鈴木次郎 2017/4/23 3800 2017/4/30 2500 2017/5/10 3000 2017/5/1 2501 2017/5/2 2502 6 山本太郎 4月30日 3200 山本太郎 2017/4/30 3200 2017/5/20 2900 7 吉田拓郎 2017/6/1 7777 8 9 10 山田花子 5月6日 2800 11 鈴木次郎 5月10日 3000 5月1日 2501 5月2日 2502 12 山本太郎 5月20日 2900 13 14 吉田拓郎 6月1日 7777
Sub Samle() 'βさんのプログラムがベース
Dim c As Range
Dim r As Range
Dim d As Range
Dim dic As Object
Dim k As Variant
Dim x As Long
Dim w As Variant
Application.ScreenUpdating = False
Set dic = CreateObject("Scripting.Dictionary")
For Each c In Range("C4", Range("C" & Rows.Count).End(xlUp))
If Not IsEmpty(c.Value) Then
If Not dic.exists(c.Value) Then
Set dic(c.Value) = CreateObject("System.Collections.ArrayList")
End If
End If
Set r = Nothing
On Error Resume Next
Set r = Cells(c.Row, "AK").Resize(, 20).SpecialCells(xlCellTypeConstants, xlNumbers)
On Error GoTo 0
If Not r Is Nothing Then
For Each d In r
dic(c.Value).Add d.Value
Next
End If
Next
Intersect(ActiveSheet.UsedRange.Rows, Columns("DW:LN")).ClearContents
Range("DW4").Resize(dic.Count).Value = WorksheetFunction.Transpose(dic.keys)
x = 4
For Each k In dic
w = dic(k).toarray
Cells(x, "DX").Resize(, UBound(w) + 1).Value = w
x = x + 1
Next
End Sub
（半平太） 2017/03/29(水) 11:27
オブジェクト変数またはWithブロック変数が設定されていません。
（右近） 2017/03/29(水) 16:54
済みません。エラーの原因になりそうな部分を幾つか修正しました。
Sub Samle() 'βさんのプログラムがベース
Dim c As Range
Dim r As Range
Dim d As Range
Dim dic As Object
Dim k As Variant
Dim x As Long
Dim w As Variant
Application.ScreenUpdating = False
Set dic = CreateObject("Scripting.Dictionary")
For Each c In Range("C4", Range("C" & Rows.Count).End(xlUp))
If Not IsEmpty(c.Value) Then
If Not dic.exists(c.Value) Then
Set dic(c.Value) = CreateObject("System.Collections.ArrayList")
dic(c.Value).Add c.Value
End If
Set r = Nothing
On Error Resume Next
Set r = Cells(c.Row, "AK").Resize(, 20).SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not r Is Nothing Then
For Each d In r
dic(c.Value).Add d.Value
Next
End If
End If
Next
On Error Resume Next
Intersect(ActiveSheet.UsedRange.Rows, Columns("DW:LN")).ClearContents
On Error GoTo 0
x = 4
For Each k In dic
w = dic(k).toarray
Cells(x, "DW").Resize(, UBound(w) + 1).Value = w
x = x + 1
Next
End Sub
（半平太） 2017/03/29(水) 22:04
半平太さん、この抽出形式について、もう一つお尋ねしてもよいでしょうか？
今回の場合は、１行に日付と番号という形ですが、例えば、２行にして上が日付、下が番号という形にすることも可能なのでしょうか？
その場合は、
Intersect(ActiveSheet.UsedRange.Rows, Columns("DW:LN")).ClearContents
この部分の修正となるのでしょうか？
ご教授願います。
（右近） 2017/03/29(水) 22:37
＞Intersect(ActiveSheet.UsedRange.Rows, Columns("DW:LN")).ClearContents
それは、打ち出しエリアを更地にするステートメントです。
何度も実行することを考えると、前回の結果が残っており、且つ前回のデータの方が多いと、 新しい結果を貼り付けても、前回の一部が残って見えるので、前回分を完全に消去する必要があります。
＞今回の場合は、１行に日付と番号という形ですが、 ＞例えば、２行にして上が日付、下が番号という形にすることも可能なのでしょうか？
当然、可能ですけど、入力側の話ですか、出力側の話ですか、それとも両方ですか？
（半平太） 2017/03/29(水) 22:50
出力側は2段ベース
Sub Samle() 'βさんのプログラムがベース
Dim c As Range
Dim r As Range
Dim d As Range
Dim dic As Object
Dim k As Variant
Dim x As Long
Dim w As Variant
Dim Col As Long
Application.ScreenUpdating = False
Set dic = CreateObject("Scripting.Dictionary")
For Each c In Range("C4", Range("C" & Rows.Count).End(xlUp))
If Not IsEmpty(c.Value) Then
If Not dic.exists(c.Value) Then
Set dic(c.Value) = CreateObject("System.Collections.ArrayList")
dic(c.Value).Add c.Value
End If
Set r = Nothing
On Error Resume Next
Set r = Cells(c.Row, "AK").Resize(, 20).SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not r Is Nothing Then
For Each d In r
dic(c.Value).Add d.Value
Next
End If
End If
Next
On Error Resume Next
Intersect(ActiveSheet.UsedRange.Rows, Columns("DW:LN")).ClearContents
On Error GoTo 0
x = 4
For Each k In dic
w = dic(k).toarray
Col = 0
For Col = 0 To UBound(w) Step 2
If Col = 0 Then
Cells(x, "DW").Value = w(Col)
Else
Cells(x, "DW").Offset(, Col / 2).Value = w(Col - 1)
Cells(x, "DW").Offset(1, Col / 2).Value = w(Col)
End If
Next Col
x = x + 2
Next
End Sub
’※ 出力エリアのセルの書式は適切に設定してください。
（半平太） 2017/03/29(水) 23:21
（右近） 2017/03/30(木) 05:28
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.