[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『関数またはマクロを使用して集計とりたいのですが』(マナ)
Excel 2013を使用してます。
2016,2017,2018の年度別にしているシートがあります。
各シートに日付(年月日)、あ客様名、品物、申込日、引渡日等の項目があります。
年度事に、申込日と引渡日の集計をしていますが、年度がまたがることがあり、集計が手入力となっています。もっと簡単にする方法があれば教えていただきたいのです。
今使用してるシートの例です
2016年度のシート
A B C D E 1 日付 お客様名 品物 申込日 引渡日 2 2016/5/5 Aさん ◯◯ 2016/8/7 2016/9/10 3 2017/3/5 Bさん ◯◯ 2017/3/30 2017/4/1 4 2017/3/8 Cさん ◯◯ 2017/3/31 2018/8/1
2017年度のシート
A B C D E 1 日付 お客様名 品物 申込日 引渡日 2 2017/4/8 Dさん ◯◯ 2017/5/8 2017/5/15 3 2017/4/10 Eさん ◯◯ 2017/5/19 2018/8/7
2018年度のシート
A B C D E 1 日付 お客様名 品物 申込日 引渡日 2 2018/7/11 Fさん ◯◯ 2018/8/1 2018/8/30 3 2018/7/20 Gさん ◯◯ 2018/8/5 2018/8/31
(集計表の例として)
年度の指定をしてデータが反映出来るような感じでお願いします。
(B1のセルに年度をしていする)
A B C D E 1 年度指定 2018 2 申込月 申込件数 引渡件数 3 4月 4 5月 5 6月 6 7月 7 8月 2件 4件
という集計表作成は可能でしょうか。
< 使用 Excel:Excel2013、使用 OS:Windows10 >
(γ) 2019/10/30(水) 13:20
2016,2017,2018年度のsheetを1つにまとめて
集計表のsheetにCOUNTIFS関数を使用するということでしょうか?
(マナ) 2019/10/30(水) 14:02
回答ではありませんが
ここの回答者常連の「マナ」さんではないですよね? でしたら、すでにそのニックネームは使われており、混乱の元になると思いますので 変更されることをお勧めします。
(渡辺ひかる) 2019/10/30(水) 14:08
Dim dic As Object, sht As Worksheet, c As Range Set dic = CreateObject("Scripting.Dictionary") For Each sht In Worksheets If sht.Name <> "集計表" And sht.Range("A1").Value = "日付" And sht.Range("B1").Value = "お客様名" And sht.Range("C1").Value = "品物" And sht.Range("D1").Value = "申込日" And sht.Range("E1").Value = "引渡日" Then If WorksheetFunction.CountA(sht.Range("D:E")) > 0 Then For Each c In sht.Range("D:E").SpecialCells(2) If IsDate(c.Value) Then dic(Year(c.Value) & "年" & Month(c.Value) & "月" & c.Column) = _ Val(dic(Year(c.Value) & "年" & Month(c.Value) & "月" & c.Column)) + 1 End If Next c End If End If Next sht For Each c In Sheets("集計表").Range("A3:A" & Rows.Count).SpecialCells(2) c.Offset(, 1).Value = dic(Sheets("集計表").Range("B1").Value & "年" & Val(c.Text) & "月" & 4) c.Offset(, 2).Value = dic(Sheets("集計表").Range("B1").Value & "年" & Val(c.Text) & "月" & 5) Next c End Sub (mm) 2019/10/30(水) 14:17
集計表
A B C 1 年度指定 2018 2 申込月 申込件数 引渡件数 3 4月 4 5月 5 6月 6 7月 7 8月 5
となりました。また
A B C 1 年度指定 2017 2 申込月 申込件数 引渡件数 3 4月 1 4 5月 2 5 6月 6 7月 7 8月
となってしまいます。
(平井) 2019/10/30(水) 16:26
こんばんは!
集計シートのシートモジュールに貼り付けます。
ちょっと検証不足気味ですが、、、後は、、応用してください。
ちなみに↓みたいになりました。。。
では、、では、、
年度指定 2016 申込月 申込件数 引渡件数 4月 5月 6月 7月 8月 1 9月 1 10月 11月 12月 1月 2月 3月 2
年度指定 2017 申込月 申込件数 引渡件数 4月 1 5月 2 1 6月 7月 8月 9月 10月 11月 12月 1月 2月 3月
年度指定 2018 申込月 申込件数 引渡件数 4月 5月 6月 7月 8月 2 4 9月 10月 11月 12月 1月 2月 3月
Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim 開始日 As Date Dim 終了日 As Date Dim ws As Worksheet Dim MyA As Variant Dim 申込み As Variant Dim 引渡し As Variant Dim 月() As Date Dim i As Long If Target.Address(0, 0) <> "B1" Then Exit Sub If Not IsNumeric(Target.Value) Then Exit Sub 開始日 = DateSerial(Target.Value, 4, 1) 終了日 = DateSerial(Target.Value + 1, 3, 31) ReDim 申込み(11) ReDim 引渡し(11) ReDim 月(11) For i = LBound(申込み) To UBound(申込み) If i >= 3 Then 月(i) = DateSerial(Target.Value, i + 1, 1) Else 月(i) = DateSerial(Target.Value + 1, i + 1, 1) End If Next For Each ws In ThisWorkbook.Worksheets If ws.Name <> Me.Name Then MyA = ws.Range("A1").CurrentRegion.Resize(, 5).Value For i = LBound(MyA, 1) To UBound(MyA, 1) If (MyA(i, 4) >= 開始日) * (MyA(i, 4) <= 終了日) Then 申込み(Month(MyA(i, 4)) - 1) = 申込み(Month(MyA(i, 4)) - 1) + 1 If (MyA(i, 5) >= 開始日) * (MyA(i, 5) <= 終了日) Then 引渡し(Month(MyA(i, 5)) - 1) = 引渡し(Month(MyA(i, 5)) - 1) + 1 Next End If Next Application.ScreenUpdating = False Application.EnableEvents = False With Me .Range("A3").Resize(UBound(月) + 1).Value = Application.Transpose(月) .Range("B3").Resize(UBound(申込み) + 1).Value = Application.Transpose(申込み) .Range("C3").Resize(UBound(引渡し) + 1).Value = Application.Transpose(引渡し) .Sort.SortFields.Clear .Sort.SortFields.Add Key:=.Range("A3"), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With .Sort .SetRange Range("A3:C14") .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With .Range("A3:A14").NumberFormat = "m月" End With Application.EnableEvents = True Application.ScreenUpdating = True Erase MyA, 申込み, 引渡し End Sub (SoulMan) 2019/10/30(水) 20:48
こんばんは!
どこかで見たことがあると思えば、、(^^;
↓これは記録したものを加工したものなのでヴァージョンによっては駄目な時があるのかもしれませんね。
.Sort.SortFields.Clear .Sort.SortFields.Add Key:=.Range("A3"), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With .Sort .SetRange Range("A3:C14") .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With
対策としては、↑この部分をコメントにして
.Range("A3:C14").Sort Key1:=.Range("A3"), Order1:=xlAscending
とするか
または、、配列を一つ追加して、、QuickSort で並び替えるか でしょうか?
簡略のSortなら↓
Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim 開始日 As Date Dim 終了日 As Date Dim ws As Worksheet Dim MyA As Variant Dim 申込み As Variant Dim 引渡し As Variant Dim 月() As Date Dim i As Long If Target.Address(0, 0) <> "B1" Then Exit Sub If Not IsNumeric(Target.Value) Then Exit Sub 開始日 = DateSerial(Target.Value, 4, 1) 終了日 = DateSerial(Target.Value + 1, 3, 31) ReDim 申込み(11) ReDim 引渡し(11) ReDim 月(11) For i = LBound(申込み) To UBound(申込み) If i >= 3 Then 月(i) = DateSerial(Target.Value, i + 1, 1) Else 月(i) = DateSerial(Target.Value + 1, i + 1, 1) End If Next For Each ws In ThisWorkbook.Worksheets If ws.Name <> Me.Name Then MyA = ws.Range("A1").CurrentRegion.Resize(, 5).Value For i = LBound(MyA, 1) To UBound(MyA, 1) If (MyA(i, 4) >= 開始日) * (MyA(i, 4) <= 終了日) Then 申込み(Month(MyA(i, 4)) - 1) = 申込み(Month(MyA(i, 4)) - 1) + 1 If (MyA(i, 5) >= 開始日) * (MyA(i, 5) <= 終了日) Then 引渡し(Month(MyA(i, 5)) - 1) = 引渡し(Month(MyA(i, 5)) - 1) + 1 Next End If Next Application.ScreenUpdating = False Application.EnableEvents = False With Me .Range("A3").Resize(UBound(月) + 1).Value = Application.Transpose(月) .Range("B3").Resize(UBound(申込み) + 1).Value = Application.Transpose(申込み) .Range("C3").Resize(UBound(引渡し) + 1).Value = Application.Transpose(引渡し) .Range("A3:C14").Sort Key1:=.Range("A3"), Order1:=xlAscending .Range("A3:A14").NumberFormat = "m月" End With Application.EnableEvents = True Application.ScreenUpdating = True Erase MyA, 申込み, 引渡し, 月 End Sub
QuickSort なら
↓こんなかんじでしょうか?
Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim 開始日 As Date Dim 終了日 As Date Dim ws As Worksheet Dim MyA As Variant Dim 申込み As Variant Dim 引渡し As Variant Dim 月() As Date Dim v As Variant Dim i As Long If Target.Address(0, 0) <> "B1" Then Exit Sub If Not IsNumeric(Target.Value) Then Exit Sub 開始日 = DateSerial(Target.Value, 4, 1) 終了日 = DateSerial(Target.Value + 1, 3, 31) ReDim 申込み(11) ReDim 引渡し(11) ReDim 月(11) For i = LBound(申込み) To UBound(申込み) If i >= 3 Then 月(i) = DateSerial(Target.Value, i + 1, 1) Else 月(i) = DateSerial(Target.Value + 1, i + 1, 1) End If Next For Each ws In ThisWorkbook.Worksheets If ws.Name <> Me.Name Then MyA = ws.Range("A1").CurrentRegion.Resize(, 5).Value For i = LBound(MyA, 1) To UBound(MyA, 1) If (MyA(i, 4) >= 開始日) * (MyA(i, 4) <= 終了日) Then 申込み(Month(MyA(i, 4)) - 1) = 申込み(Month(MyA(i, 4)) - 1) + 1 If (MyA(i, 5) >= 開始日) * (MyA(i, 5) <= 終了日) Then 引渡し(Month(MyA(i, 5)) - 1) = 引渡し(Month(MyA(i, 5)) - 1) + 1 Next End If Next ReDim v(1 To 12, 1 To 3) For i = LBound(月) To UBound(月) v(i + 1, 1) = CLng(月(i)) v(i + 1, 2) = 申込み(i) v(i + 1, 3) = 引渡し(i) Next QuickSort v, 1, LBound(v, 1), UBound(v, 1) Application.ScreenUpdating = False Application.EnableEvents = False With Me .Range("A3").Resize(UBound(v, 1), UBound(v, 2)).Value = v .Range("A3:A14").NumberFormat = "m月" End With Application.EnableEvents = True Application.ScreenUpdating = True Erase MyA, 申込み, 引渡し, 月, v End Sub Private Sub QuickSort(MySAry As Variant, ByVal MySKey As Long, ByVal MySLeft As Long, ByVal MySRight As Long) Dim MySMid As Double Dim i As Long, j As Long, n As Long Dim MySLBound As Long, MySUBound As Long Dim MyStmp As String MySLBound = LBound(MySAry, 2) MySUBound = UBound(MySAry, 2) MySMid = MySAry((MySLeft + MySRight) \ 2, MySKey) i = MySLeft j = MySRight Do Do While MySAry(i, MySKey) < MySMid i = i + 1 Loop Do While MySAry(j, MySKey) > MySMid j = j - 1 Loop If i >= j Then Exit Do For n = MySLBound To MySUBound MyStmp = MySAry(i, n) MySAry(i, n) = MySAry(j, n) MySAry(j, n) = MyStmp Next i = i + 1 j = j - 1 Loop If MySLeft < i - 1 Then QuickSort MySAry, MySKey, MySLeft, i - 1 If MySRight > j + 1 Then QuickSort MySAry, MySKey, j + 1, MySRight End Sub (SoulMan) 2019/11/05(火) 20:51
マナさんの例を変更して
2016、2017、2018のシート
EA EB EC ED EE 5 日付 お客様名 品物 申込日 引渡日 6 2016/5/5 Aさん ◯◯ 2016/8/7 2016/9/10 7 2017/3/5 Bさん ◯◯ 2017/3/30 2017/4/1 8 2017/3/8 Cさん ◯◯ 2017/3/31 2018/8/1
集計表
A B C D E 1 年度指定 2018 18 申込月 申込件数 引渡件数 19 4月 20 5月 21 6月 22 7月 23 8月 2件 4件
(SoulMan)さんのを使用しています↓
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim 開始日 As Date
Dim 終了日 As Date
Dim ws As Worksheet
Dim MyA As Variant
Dim 申込み As Variant
Dim 引渡し As Variant
Dim 月() As Date
Dim i As Long
If Target.Address(0, 0) <> "B1" Then Exit Sub
If Not IsNumeric(Target.Value) Then Exit Sub
開始日 = DateSerial(Target.Value, 4, 1)
終了日 = DateSerial(Target.Value + 1, 3, 31)
ReDim 申込み(11)
ReDim 引渡し(11)
ReDim 月(11)
For i = LBound(申込み) To UBound(申込み)
If i >= 3 Then 月(i) = DateSerial(Target.Value, i + 1, 1) Else 月(i) = DateSerial(Target.Value + 1, i + 1, 1) End If Next For Each ws In ThisWorkbook.Worksheets If ws.Name <> Me.Name Then MyA = ws.Range("A1").CurrentRegion.Resize(, 5).Value For i = LBound(MyA, 1) To UBound(MyA, 1) If (MyA(i, 4) >= 開始日) * (MyA(i, 4) <= 終了日) Then 申込み(Month(MyA(i, 4)) - 1) = 申込み(Month(MyA(i, 4)) - 1) + 1 If (MyA(i, 5) >= 開始日) * (MyA(i, 5) <= 終了日) Then 引渡し(Month(MyA(i, 5)) - 1) = 引渡し(Month(MyA(i, 5)) - 1) + 1 Next End If Next Application.ScreenUpdating = False Application.EnableEvents = False With Me .Range("A3").Resize(UBound(月) + 1).Value = Application.Transpose(月) .Range("B3").Resize(UBound(申込み) + 1).Value = Application.Transpose(申込み) .Range("C3").Resize(UBound(引渡し) + 1).Value = Application.Transpose(引渡し) .Range("A3:C14").Sort Key1:=.Range("A3"), Order1:=xlAscending .Range("A3:A14").NumberFormat = "m月" End With Application.EnableEvents = True Application.ScreenUpdating = True Erase MyA, 申込み, 引渡し, 月 End Sub
(初心) 2019/11/06(水) 14:56
こんばんは! うれちぃなぁ、、わちきのコードを参考にしてくれる人がいらっしゃるとは。。。(^^;
でも、参考にされるのでしたら、、配列の QuickSort 版がお勧めです。 配列、、というと一見敷居が高い様に思われがちですが、、慣れれば、、全然普通です。
私なんかは、Sheetに触る方が嫌です。(^^; ご提示のコードでは、三回もSheetに触ってますが、、普段の私なら考えられないことです。。(多分、、わかり難いとか言われて心が病んでいたんでしょう(^^;)←結構、、根に持つ(^^;
で、↓ここが、データを取得するとこです。。 MyA = ws.Range("A1").CurrentRegion.Resize(, 5).Value
これを↓ MyA = ws.Range("EA5").CurrentRegion.Resize(, 5).Value
と言いたいところですが、、CurrentRegion を使っているので一概には言い切れません。。
ここは、、配列の中のインデックスという概念を理解しながら、別途、、質問されればいいでしょう。。(簡単、、です。(^^;)
で、配列のいいところは、、これが、出力先です。
.Range("A3").Resize(UBound(v, 1), UBound(v, 2)).Value = v
なので、、
.Range("C18").Resize(UBound(v, 1), UBound(v, 2)).Value = v
となります。。。
まぁ、、こんなかんじでしょうか?おわかりになりましたでしょうか??? (SoulMan) 2019/11/06(水) 20:14
あと、実行したところ、
集計表
A B C D E 1 年度指定 2018 18 申込月 申込件数 引渡件数 19 1月 20 2月 21 3月 22 4月 23 5月
と、C19が1月になってしまいます。これを4月スタートで3月が最終となるように変更するのはどこを変更さればよろしいのでしょうか。重ね重ねすみません。
(初心) 2019/11/07(木) 13:13
こんばんは! レイアウトのことについてここで議論しても効率が悪いと思いますので、 もしよかったら、↓の中にあるちょっとふざけた名前のコードを使ってここへUpしてみませんか? [[20190108133640]]
あっ、無理にとはいいません。良かったらです。。この間、思いっきり無視されちゃいましたから(^^; Upされる時は、一度、ご自身で再現されてからUpしてくださいね。
データ量が多いと駄目な時がありますから、、適当に調整してください。 くれぐれも個人情報には注意してくださいね。Up用に新規Bookを作られることをお勧め致します。
では、、では、、また、、お会い出来ることを楽しみにしています。 (SoulMan) 2019/11/07(木) 20:06
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.