[[20191030112037]]　『関数またはマクロを使用して集計とりたいのですが』（マナ）　ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

　

『関数またはマクロを使用して集計とりたいのですが』（マナ）

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 ＞

---

ちょっと粗すぎるコメントをしてしまったので、いったん取り消し。
シートを1つにまとめて、ピボットテーブルという方向でしょうけど。

（γ） 2019/10/30(水) 13:20

---

ああ、ひとつのシートにまとめて、COUNTIFS関数のほうが手っ取早いですね。
（γ） 2019/10/30(水) 13:44

---

ありがとうございます。

2016,2017,2018年度のsheetを１つにまとめて
集計表のsheetにCOUNTIFS関数を使用するということでしょうか？

（マナ） 2019/10/30(水) 14:02

---

 回答ではありませんが

 ここの回答者常連の「マナ」さんではないですよね？
 でしたら、すでにそのニックネームは使われており、混乱の元になると思いますので
 変更されることをお勧めします。

（渡辺ひかる） 2019/10/30(水) 14:08

---

失礼しました。その常連『マナ』さんではありません。
ニックネーム変更します。旧姓の『平井』にします。
（マナ改めて、『平井』） 2019/10/30(水) 14:14

---

Sub main()

    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

---

mmさん、ありがとうございます。
コードを入力しましたところ、

集計表

   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

---

SoulManさん、返事が遅れて申し訳ありませんでした。
仕事場で試したことろ、無事にできそうです。回数も試したところ、不具合もなくスムーズにできておりました。本当にありがとうございました。ｍｍさんもありがとうございました。
大事に使用させていただきたく思います。
（平井） 2019/11/04(月) 15:54

---

『xlSortOnValues』
でコンパイルエラー
変数が定義されてませんと表示されます。何故でしょうか？
（ゆうた） 2019/11/05(火) 18:25

---

 こんばんは！

 どこかで見たことがあると思えば、、(^^;

 ↓これは記録したものを加工したものなのでヴァージョンによっては駄目な時があるのかもしれませんね。

 .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

---

SoulManさん、ありかとうございます。QuickSortを使用して実行したところ、スムーズにできました。物凄く便利な機能で助かりました！
コードを理解するのに苦労しそうですが(笑)

あと、実行したところ、

集計表

    A             B         C             D           E
1  年度指定       2018
18                          申込月       申込件数     引渡件数
19                          1月     
20                          2月
21                          3月
22                          4月
23                          5月                   

と、C19が１月になってしまいます。これを４月スタートで３月が最終となるように変更するのはどこを変更さればよろしいのでしょうか。重ね重ねすみません。
（初心） 2019/11/07(木) 13:13

---

 こんばんは！
レイアウトのことについてここで議論しても効率が悪いと思いますので、
もしよかったら、↓の中にあるちょっとふざけた名前のコードを使ってここへUpしてみませんか？
[[20190108133640]]

 あっ、無理にとはいいません。良かったらです。。この間、思いっきり無視されちゃいましたから(^^;
Upされる時は、一度、ご自身で再現されてからUpしてくださいね。

 データ量が多いと駄目な時がありますから、、適当に調整してください。
くれぐれも個人情報には注意してくださいね。Up用に新規Bookを作られることをお勧め致します。

 では、、では、、また、、お会い出来ることを楽しみにしています。
（SoulMan） 2019/11/07(木) 20:06

---

ありがとうございます！
内容読まさせてもらいました➰というか、頭だけがどこかに飛んでいった感じです(泣)
、、、そして考えるのをやめた(ジョジョ、カーズの言葉w)
ってならないように携帯から職場のパソコンに転記から始めないと💦
（初心） 2019/11/07(木) 20:29

---

コメント返信：

---

[ 一覧(最新更新順) ]

---

YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.