新生活を充実させるための「こだわり」を取材!!

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

1.元データシートに
A列 日付
B列 商品


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


A列  B列  日付 
名前  商品


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

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

「超難 日付に対するクロス集計」の質問画像

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

  • つらい・・・

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

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

    それと右側のA列・B列はその出力であってますか?
    あってないです。

    ⇒何となくですが昨年位に回答した物に似ているような???
    すみません わたしなりに解決できないかった。

    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
  • A列・B列はその出力とは
    下記のように書き出したいです。
    ただ
    あっているかはわかりません。

    名前 商品
    Aさん
    バナナ
    みかん
    ぶどう
    キウイ
    りんご
    もも
    メロン
    なし
    レモン

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

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

      補足日時:2021/12/06 21:35
  • うーん・・・

    日付の転記については画像から
    ・日付は昇順に並んでいる。
    並んでいます。

    ・重複は存在しない。
    存在しません

    ・日にちが飛んでる箇所もない。
    日にち飛んでいる箇所あります。

    例えば同じ人が同日に複数の商品をとかね
    ある可能性もあります。
    すみせんです。
    お忙しいところ

    No.3の回答に寄せられた補足コメントです。 補足日時:2021/12/07 08:25
教えて!goo グレード

A 回答 (7件)

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


テーブルーが作成されると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
    • good
    • 2
この回答へのお礼

ありがとうございます。

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

>本当のところは


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

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

上記①②のどちらなのでしょうか。
    • good
    • 0
この回答へのお礼

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

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

No.5です。


画像添付もれしていました。
添付画像①のような元データのテーブルが「テーブル1」だったとして、前回回答のコードを実行した結果が添付画像②になります。
「超難 日付に対するクロス集計」の回答画像6
    • good
    • 1
この回答へのお礼

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

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

漏れてました。



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

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

と、スマホではこの位になってしまいます。
    • good
    • 0
この回答へのお礼

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

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

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


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

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

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

ありがとうございます。

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

No.1です。



>>それと右側のA列・B列はその出力であってますか?
>あってないです。

ではどの様に?
B2から商品名を並べ一番最後の商品名のある次の行を1つ空けて、A列に名前・B列に商品名を並べるのかな?
この回答への補足あり
    • good
    • 0

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


あと同じ人が同じ日に同じ商品を別の行で表示されている(左側)って可能性はあるのでしょうか?
それと右側のA列・B列はその出力であってますか?
⇒何となくですが昨年位に回答した物に似ているような???
この回答への補足あり
    • good
    • 0
この回答へのお礼

ありがとうございます。

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

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

教えて!goo グレード

このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング