超難 日付に対するクロス集計

いつも大変お世話になっております。
やりたいことは添付ファイルのように
書き出したいのです。

1.元データシートに
Ａ列　日付
Ｂ列　商品


2.データ書き出し　シート


Ａ列　　Ｂ列　　日付　
名前　　商品


下記のコードは
未完成でここまでしかできませんでした。
わかる方おしえてくれませんでしょうか

Sub sample()
Dim Dic As Object, wf As Object
Dim R As Range
Dim wS As Worksheet
Set Dic = CreateObject("Scripting.Dictionary")
Set wS = Sheets("Sheet4") '元データシート
Set wSk = Sheets("データ書き出し")
Set wf = WorksheetFunction

For Each R In wS.Range("A2", Range("A" & Rows.Count).End(xlUp))
key = R.Offset(, 2).Value & "_" & R.Offset(, 1).Value

If Not Dic.Exists(key) Then
Dic.Add key, 0
End If
Next

sDate = wf.Min(wS.Range("A:A")) '最小日
wS.Range("C1").Value = sDate '最小日

eDate = wf.Max(wS.Range("A:A")) '最大日
'-------------------------------------------------------
Set wSk = Sheets("データ書き出し") '結果シート

wSk.Range("A1").Value = "名前"
wSk.Range("B1").Value = "商品"

wSk.Range("c1").AutoFill Destination:= _
wSk.Range("c1").Resize(1, eDate - sDate + 1), _
Type:=xlFillDefault 'C1から右に最小日から最大日まで

wSk.Range("1:1").NumberFormat = "m/d" '日付の書式

Set rr = wSk.Range("A2")

For Each key In Dic.keys
rr.Resize(, 2) = Split(key, "_")
rr.Offset(, 3).Resize(, 100) = Dic(key)
Next

End Sub

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

• 

  画像の右側ってミスっている状態ですよね？
  はい
  
  あと同じ人が同じ日に同じ商品を別の行で表示されている（左側）って可能性はあるのでしょうか？
  ないです。
  
  それと右側のＡ列・Ｂ列はその出力であってますか？
  あってないです。
  
  ⇒何となくですが昨年位に回答した物に似ているような？？？
  すみません　わたしなりに解決できないかった。

  No.1の回答に寄せられた補足コメントです。 補足日時：2021/12/06 21:12

• 

  本当のところは
  下記のコードを短くしたいのです。
  何回かに分けます。
  
  Sub sample()
  Dim Dic As Object
  Dim wS As Worksheet
  Dim lastRow As Long
  Dim R As Long
  Dim dt As Variant 'Date
  Dim pr As Variant 'String
  Dim nm As Variant 'String
  Dim sDate As Date
  Dim eDate As Date
  Dim rng As Range
  '

    補足日時：2021/12/06 21:27

• Set Dic = CreateObject("Scripting.Dictionary") 'Dictionaryオブジェクト
  Set wS = Sheets("Jag04") '元データシート
  lastRow = wS.Range("A" & Rows.Count).End(xlUp).Row
  
  For R = 2 To lastRow
  dt = wS.Range("A" & R).Value '日付
  pr = wS.Range("B" & R).Value '商品
  nm = wS.Range("C" & R).Value '名前

    補足日時：2021/12/06 21:28

• If Not Dic.Exists(nm) Then
  Dic.Add nm, CreateObject("Scripting.Dictionary")
  End If
  If Not Dic(nm).Exists(pr) Then
  Dic(nm).Add pr, CreateObject("Scripting.Dictionary")
  End If
  If Not Dic(nm)(pr).Exists(dt) Then
  Dic(nm)(pr).Add dt, 0
  End If
  Dic(nm)(pr)(dt) = Dic(nm)(pr)(dt) + 1
  Next
  
  sDate = WorksheetFunction.Min(wS.Range("A:A")) '最小日
  eDate = WorksheetFunction.Max(wS.Range("A:A")) '最大日

    補足日時：2021/12/06 21:28

• Set wS = Sheets("Jag04抽出") '結果シート
  'ws.Cells.ClearContents
  wS.Range("A1").Value = "名前"
  wS.Range("B1").Value = "商品"
  wS.Range("C1").Value = sDate '最小日
  wS.Range("c1").AutoFill Destination:=wS.Range("c1").Resize(1, eDate - sDate + 1), Type:=xlFillDefault 'C1から右に最小日から最大日まで

    補足日時：2021/12/06 21:29

• wS.Range("1:1").NumberFormat = "m/d" '日付の書式
  R = 2 '結果表示行(初期値=2)
  For Each nm In Dic.keys 'dictionaryのキー(名前)を順に
  wS.Range("A" & R).Value = nm 'A列に名前
  R = R + 1 '表示行+1
  For Each pr In Dic(nm).keys '名前がキーのdictionaryのキー(商品)を順に
  wS.Range("B" & R).Value = pr 'B列に商品
  R = R + 1 '表示行+1
  For Each dt In Dic(nm)(pr).keys '名前がキーのdictionaryの中の商品がキーのdictionaryの中のキー(日付)を順に

    補足日時：2021/12/06 21:29

• 

  Set rng = wS.Range("1:1").Find(Format(dt, "m/d"), LookIn:=xlValues, lookat:=xlWhole) '1行目で日付を検索
  wS.Cells(R, rng.Column).Value = Dic(nm)(pr)(dt) '注目行と日付の交差するセルに名前、商品、日付がキーのdictionaryの値(個数)を表示
  Next
  Next
  R = R + 1 '表示行+1
  Next
  End Sub
  
  これが全てです。　どこか短くできるところあればおしえてくれませんでしょうか

    補足日時：2021/12/06 21:30

• Ａ列・Ｂ列はその出力とは
  下記のように書き出したいです。
  ただ
  あっているかはわかりません。
  
  名前 商品
  Ａさん
  バナナ
  みかん
  ぶどう
  キウイ
  りんご
  もも
  メロン
  なし
  レモン

  No.2の回答に寄せられた補足コメントです。 補足日時：2021/12/06 21:33

• 

  すみません
  ずれていました。
  焦っています。
  Ａ列・Ｂ列はその出力とは
  下記のように書き出したいです。
  ただ
  あっているかはわかりません。
  Ａ列　　　　Ｂ列
  名前　　 商品
  Ａさん　　バナナ
  　　　　　みかん
  　　　　　ぶどう　　　　　
  　　　　　リンゴ
  　　　　　キウイ
  　　　　　リンゴ
  　　　　　もも
  　　　　　メロン
  　　　　　なし
  　　　　　レモン

    補足日時：2021/12/06 21:35

• 

  日付の転記については画像から
  ・日付は昇順に並んでいる。
  並んでいます。
  
  ・重複は存在しない。
  存在しません
  
  ・日にちが飛んでる箇所もない。
  日にち飛んでいる箇所あります。
  
  例えば同じ人が同日に複数の商品をとかね
  ある可能性もあります。
  すみせんです。
  お忙しいところ

  No.3の回答に寄せられた補足コメントです。 補足日時：2021/12/07 08:25

No.5 ベストアンサー 回答者： goomania 回答日時： 2021/12/08 23:22

予め、元シートのデータ範囲の表を見出しまで含めて、テーブルにしておくものとします。

テーブルーが作成されるとExcelは、自動的に「テーブル1」「テーブル2」などの名称を設定してくれます。同時に、作成したテーブルに名前が定義されます。「数式」タブ⇒「名前の管理」⇒「名前の管理」ダイアログボックスで確認できます。
とりあえず、この方法で確認したら「テーブル1」という名前だったとします。
以下のコードはご質問者のご要望を拡大解釈して、「ピボットテーブルでよいのでは」と考え、ピボットテーブルを作成するサンプルです。
参考になれば幸いです。

Sub sample_12704206()
Dim pvf As PivotField
ActiveWorkbook.PivotCaches.Create(xlDatabase, _
"テーブル1").CreatePivotTable Sheets.Add.Range("A3")
With ActiveSheet.PivotTables(1)
.PivotFields("名前").Orientation = xlRowField
.PivotFields("商品").Orientation = xlRowField
.PivotFields("日付").Orientation = xlColumnField
.PivotFields("商品").Orientation = xlDataField
.RowAxisLayout xlTabularRow
On Error Resume Next
For Each pvf In .PivotFields
pvf.Subtotals(1) = True
pvf.Subtotals(1) = False
Next pvf
On Error GoTo 0
.RepeatAllLabels xlDoNotRepeatLabels
.ColumnGrand = False
.RowGrand = False
End With
With ActiveSheet
.Range("C4").Select
.Range(Selection, Selection.End(xlToRight)).Select
Selection.NumberFormatLocal = "m/d;@"
.Range("A3").Select
End With
End Sub

この回答へのお礼

ありがとうございます。

お礼日時：2021/12/09 18:59

No.7 回答者： tatsumaru77 回答日時： 2021/12/09 08:36

>本当のところは

>下記のコードを短くしたいのです。

そのコードは無駄のないコードです。短くするのは無理があります。
①そのコードを実行した結果は、期待した結果であるが更にコードを短くしたい。
②そのコードを実行した結果が期待した結果でないので、コードを修正したい。

上記①②のどちらなのでしょうか。

この回答へのお礼

ありがとうございました。
①そのコードを実行した結果は、
期待した結果であるが更にコードを短くしたい。
といことです。

お礼日時：2021/12/09 18:57

No.6 回答者： goomania 回答日時： 2021/12/09 01:19

No.5です。

画像添付もれしていました。
添付画像①のような元データのテーブルが「テーブル1」だったとして、前回回答のコードを実行した結果が添付画像②になります。

この回答へのお礼

ありがとうございます。
試しました。
速度は速いのには
驚きました。
いろいろありますね
参考にいたします。

お礼日時：2021/12/09 18:58

No.4 回答者： めぐみん_ 回答日時： 2021/12/07 13:23

漏れてました。

＞＞あと同じ人が同じ日に同じ商品を別の行で表示されている（左側）って可能性はあるのでしょうか？
＞ないです。

同じ人が『違う日』に同じ商品をって事はありますか？
この内容によっては個人的に .NETFramework3.5 を呼び出したい所ですが、最新のWin10などは無理っぽいですから代替えが必要かなと。

と、スマホではこの位になってしまいます。

この回答へのお礼

同じ人が『違う日』に同じ商品をって事はありますか？
あります。
補足に返信できなくなっていますので
こちらにかきました。

お礼日時：2021/12/07 13:26

No.3 回答者： めぐみん_ 回答日時： 2021/12/07 08:21

日付の転記については画像から

・日付は昇順に並んでいる。
・重複は存在しない。
・日にちが飛んでる箇所もない。

と言う事ならコピペの『行列入れ替え』で貼り付け書式だけ変更しては？と思えるのですが。。。

仮にイレギュラーがあるならそう言う情報も事前に組み込んでおく方が良いかと。
例えば同じ人が同日に複数の商品をとかね。

この回答へのお礼

ありがとうございます。

お礼日時：2021/12/09 18:59

No.2 回答者： めぐみん_ 回答日時： 2021/12/06 21:29

No.1です。

＞＞それと右側のＡ列・Ｂ列はその出力であってますか？
＞あってないです。

ではどの様に？
Ｂ２から商品名を並べ一番最後の商品名のある次の行を１つ空けて、Ａ列に名前・Ｂ列に商品名を並べるのかな？

No.1 回答者： めぐみん_ 回答日時： 2021/12/06 21:08

画像の右側ってミスっている状態ですよね？

あと同じ人が同じ日に同じ商品を別の行で表示されている（左側）って可能性はあるのでしょうか？
それと右側のＡ列・Ｂ列はその出力であってますか？
⇒何となくですが昨年位に回答した物に似ているような？？？

この回答へのお礼

ありがとうございます。

お礼日時：2021/12/09 18:59