エクセル関数・ＶＢＡ 条件に合致したセルの個数を重複を除いて求めたい。

こんにちは、お手数おかけしますが教えてください。
Windows10、Excel2016を使用しています。

添付写真、A1:C23の入力データがあるとします。
そのデータを元にE1:I4の別途表に集計をしたく考えています。

集計したい事は「人ごとの重複を除いた日付の個数」です。
よろしくお願いいたします。

※A～Cの各列は名前の管理にて人・日付・金額として可変で範囲指定しています。
　また、A:Cをリストとして可変で範囲指定しています。
※F1:I1は表示形式にてm月としています。入力は2017/3/1というように各月の1日です。
※E1:I4の別途表は3月～翌2月まで続きます。
※人は全部で30人います。

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

No.1 回答者： tom04 回答日時： 2017/03/22 20:55

こんばんは！

一案です。
↓の画像のように作業用の列を設けてみてはどうでしょうか？

作業列D2セルに
=IF(COUNTIFS(A$2:A2,A2,B$2:B2,B2)=1,A2&"_"&MONTH(B2),"")
という数式を入れフィルハンドルで下へこれ以上データはない！というくらいまでコピーしておきます。

G2セルに
=COUNTIF($D:$D,$F2&"_"&MONTH(G$1))

という数式を入れ、列・行方向にコピー！
これで画像のような感じになります。

※　作業列が目障りであれば、遠く離れた列にするか
非表示にしてください。m(_ _)m

この回答へのお礼

ありがとうございました。
無事に重複なくカウントできました。

お礼日時：2017/03/30 14:02

No.2 ベストアンサー 回答者： WindFaller 回答日時： 2017/03/22 21:12

こんばんは。

日付の個数というのは、同じ人が、3/1 が２つあっても、１つと勘定するという意味だと思います。後は、書き出し位置など場所さえ間違えなければ、ちゃんとした計算はされるはずです。

'//標準モジュールに貼り付けてください。
Sub SummaryperPerons()
　Dim objDic As Object 'New Scripting.Dictionary
　Dim i As Long, j As Long
　Dim LastRow As Long
　Dim Rng As Range
　Dim c As Variant, d As Variant, k As Long, p
　Dim arymon, ary
　k = 2 'E列書きだし場所
　
　With ActiveSheet
　　For i = 1 To 12
　　 .Range("E1").Offset(, i).Value = (i + 12 - 11) Mod 12 + 1 & "月"
　　Next
　　If .AutoFilterMode = True Then
　　　.AutoFilterMode = False
　　End If
　　Set objDic = CreateObject("Scripting.Dictionary")
　　Set Rng = .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
　　
　　For Each c In .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
　　　If (objDic.Exists(c.Value)) = False Then
　　　　objDic.Add c.Value, i
　　　　i = i + 1
　　　End If
　　Next c
　　ary = objDic.keys
　　
　　'人名の書き出し
　　For i = 1 To UBound(ary)
　　　.Cells(i + 1, "E").Value = ary(i - 1)
　　Next
　　
　　LastRow = Rng(Rng.Cells.Count).Row
　　objDic.RemoveAll
　　
　　ReDim arymon(12) As Integer　'月のデータ
　　Application.ScreenUpdating = False
　　'日付の集計
　　For Each p In ary
　　　.AutoFilterMode = False
　　　.Range("A1").Resize(LastRow, 3).AutoFilter
　　　.AutoFilter.Range.AutoFilter _
　　　Field:=1, _
　　　Criteria1:="=" & p
　　　For Each d In .AutoFilter.Range.Columns(2).SpecialCells(xlCellTypeVisible).Cells
　　　　d.Select
　　　　If VarType(d.Value) = vbDate Then
　　　　　If (objDic.Exists(d.Value)) = False Then
　　　　　　arymon(Month(d.Value)) = arymon(Month(d.Value)) + 1
　　　　　　objDic.Add d.Value, arymon
　　　　　　i = i + 1
　　　　　End If
　　　　End If
　　　Next
　　　'日付の出力
　　　For i = 1 To UBound(arymon)
　　　　j = (i + 12 - 11) Mod 12 + 1 '...３月が１番目の時
　　　　Cells(k, "E").Offset(, i).Value = arymon(j)
　　　Next i
　　　Erase arymon
　　　ReDim arymon(12) As Integer
　　　objDic.RemoveAll
　　　k = k + 1
　　Next
　　.AutoFilterMode = False
　　.Range("E1").Select
　End With
　Application.ScreenUpdating = True
　Beep
End Sub

この回答へのお礼

マクロ組んでいただきありがとうございました。
実際にはリストと集計表が別シートだったりするので、
もう少し勉強して実運用できるようにしたいと思います。

お礼日時：2017/03/30 14:00