日付を重複させずに数えたい

sheet1に日計のデータがあり、sheet2に集計（日数や距離など）したいです。
（添付画像を参照して下さい）
この際、担当者ごとに出勤日数を数えたいのですが、
同一人で同じ日のデータが複数あるので、重複させずに日数を数えたいです。
下記のような感じで組んでいるのですが、日数合計の出し方がわかりません。

Dim i As Long, n As Long, d As Long
Dim km As Long
Dim lrow As Long
Dim name As String

Sub total()

lrow = Worksheets("sheet1").Cells(Rows.Count, 2).End(xlUp).Row

For i = 2 To lrow

name = Worksheets("sheet1").Cells(i, 12).Value '該当データの担当者名
n = Worksheets("sheet2").Range("B3:B11").Find(what:=name, lookat:=xlWhole).Row 'sheet2の担当者行番号
d = Worksheets("sheet1").Cells(i, 2).Value '該当データの日付
km = Worksheets("sheet1").Cells(i, 11).Value '該当データの距離

'＜ここに、sheet2への集計方法を記載したい＞
'＜特に、担当の”日数”を数える方法がわからない＞

Worksheets("sheet2").Cells(n, 4).Value = Worksheets("sheet2").Cells(n, 4).Value + km
'＜距離の加算はこんな感じで良いと思います＞

Next i

End Sub

質問者からの補足コメント

• ウィンドウズ環境で希望通りの動作が確認できました！
  とはいえ、自分自身ではまだdictionaryの使い方が理解できませんので、
  頂いたソースを理解できるよう学習してみようと思います。
  この度はありがとうございました！

  No.2の回答に寄せられた補足コメントです。 補足日時：2022/12/05 10:30

No.2 ベストアンサー 回答者： tatsumaru77 回答日時： 2022/12/04 23:05

dictionaryを使用した例です。

sheet1のB14の”月末まで”は、説明上のためで、実際にはないと解釈しています。

以下のマクロを標準モジュールに登録してください。
このサイトにアップするとエラーになるので、下記URLにアップしました。
https://ideone.com/Si2qFy
不明点があれば、補足してください。

この回答へのお礼

回答、ありがとうございます。
ご丁寧にコードまで記載して頂き恐縮です。
現在、手元にMac環境しか無いので、明日、ウィンドウズ環境で試してみます。
（MacではDictionaryが使えないようなので）

お礼日時：2022/12/04 23:29

No.4 回答者： めぐみん_ 回答日時： 2022/12/05 08:15

見えないですが回答が既に付いているようですね。

重複したらこれはスル～して下さい。

距離の合計って日付は関係なく、担当者別に合計したいってならSUMIFS関数でも良かったかなと、眠気と格闘しながらそう感じました。
⇒シート２のＢ列は先に入力されているのですよね？

あとはシート３を準備しシート１のＡ・Ｂ列をシート３の２行目以下にコピペ、その後シート２のＢ列をシート３に行列反転して１行目にコピペし２行目以下の重複削除したデータを用い、COUNTIFS関数で日付＋担当者で小計を求めた後担当者毎に合計を出す。
と言うのも考えましたけど、初級レベルなジジィが時間かけて思いついたのでお若い方なら直ぐに出来てしまっているかな？

無論月を跨ぐと言う場合には変更が必要でしょうけど。

この回答へのお礼

様々な方法があるのですね。
同じゴールでも、手法はアレコレあるようなので、そういった「引き出し」が増やせるよう精進いたします。

お礼日時：2022/12/05 10:32

No.3 回答者： Qchan1962 回答日時： 2022/12/04 23:42

こんばんは

＞この際、担当者ごとに出勤日数を数えたい
ご質問のコードを反故して申し訳ないのです

各日付ごとに担当者が入っているか調べ換算する（日付はソートされている）
担当者に一致する距離を換算
結果を出力

IF分岐だと解り難くなってしまいそうなので１つ１つ分けて
（一例です　改修や他の処理を加えやすいと思います）

Sub test0()
Dim Sht1 As Worksheet, Sht2 As Worksheet
Set Sht1 = Worksheets("sheet1")
Set Sht2 = Worksheets("sheet2")
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
Dim r As Range
'担当者リストを作成　前準備
For Each r In Range(Sht1.Cells(2, "L"), Sht1.Cells(Rows.Count, "L").End(xlUp))
If Not Dic.exists(r.Value) Then
Dic.Add r.Value, 0#
End If
Next r

'同日範囲取得（纏まっている事が必須）前準備
Dim srtR As Range
Dim stAddress As String
Set srtR = Sht1.Cells(2, "B")
For Each r In Range(srtR, Sht1.Cells(Rows.Count, "B").End(xlUp).Offset(1))
If r.Value <> srtR.Value Then
If stAddress <> "" Then
stAddress = stAddress & "," & Range(srtR, r.Offset(-1)).AddressLocal(0, 0)
Else
stAddress = Range(srtR, r.Offset(-1)).AddressLocal(0, 0)
End If
Set srtR = r
End If
Next r

Dim arr(), k As Variant
Dim i As Integer, n As Long
'出力配列サイズ設定
ReDim arr(Dic.Count, 2)
'担当者リストを基に算出（前処理変数を使って）
For Each k In Dic
'同日処理
For i = 1 To Range(stAddress).Areas.Count
If Application.CountIf(Sht1.Range(stAddress).Areas(i).Offset(, 10), k) > 0 Then
arr(n, 0) = k '担当者を出力配列に
arr(n, 1) = arr(n, 1) + 1　 '日数を換算出力配列に
End If
Next
'距離集計
For Each r In Range(Sht1.Cells(2, "B"), Sht1.Cells(Rows.Count, "B").End(xlUp))
If k = r.Offset(, 10).Value Then arr(n, 2) = arr(n, 2) + r.Offset(, 9).Value　'距離を積算　出力配列に
Next r
n = n + 1
Next

'結果出力
Sht2.Cells(3, "B").Resize(UBound(arr, 1) + 1, UBound(arr, 2) + 1).Value = arr
End Sub

この回答へのお礼

ご回答、ありがとうございます。
ウィンドウズ環境で希望通りの動作が確認できました！
（Mac環境ではdictionaryが使えないようですが、Winなら動きました）
とはいえ、自分自身ではまだdictionaryの使い方が理解できませんので、
頂いたソースを理解できるよう学習してみようと思います。
この度はありがとうございました！

お礼日時：2022/12/05 10:31

No.1 回答者： めぐみん_ 回答日時： 2022/12/04 18:48

＞lrow = Worksheets("sheet1").Cells(Rows.Count, 2).End(xlUp).Row

シート１のＢ１４には文字が入っているようですが、最終行をそこにして良いのでしょうか？
Ａ１４は空白セルのようですが、Ａ列で取得するなら最終行は１３行目になりますよね？
何らかの狙いあっての事ですか？

過去質で検索するなら良く見かけるのはDictionary オブジェクトの使用でしょうかね。
このような感じの物です。
http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/v …

この回答へのお礼

回答、ありがとうございます。
Dictionaryかなーとは漠然と思っておりますが、なかなか難しいので勉強してみます。

お礼日時：2022/12/04 23:28