【エクセル】横に並んでいるものを縦に並べる

エクセルで横に並んでいるセルを１列に対して１ユーザー１種類・１商品、購入日時で並べ直したいです。

添付の画像で説明すると
A1：鈴木さん　B１：飲料　C１：ビール　D１：2017/10/17
A2：鈴木さん　B２：飲料　C２：ウーロン茶　D２：2017/10/17
A3：鈴木さん　B３：お菓子　C3：チョコ　D３：2017/10/17
・
・
A6　伊藤さん　B６：飲料　C６：ビール　D６：2017/10/17

というような感じです。
種類と商品は最大５つまでしか横に並んでいません。
実際には列がたくさんあるので、簡単にできる方法が知りたいです。
解決方法教えてください。
よろしくお願いいたします。

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

• tom04さん
  
  ありがとうございます。
  日付はバラバラなんです。。。

  No.1の回答に寄せられた補足コメントです。 補足日時：2017/12/13 18:47

No.4 ベストアンサー 回答者： mike_g 回答日時： 2017/12/13 23:41

Sheet2 において、

A1: =OFFSET(Sheet1!A$2,(ROW(A1)-1)/5,)
B1: =OFFSET(Sheet1!B$2,(ROW(A1)-1)/5,MOD((ROW(A1)-1)*2,10))&""
セル B1 をセル C1 にコピー＆ペースト
D1： =IF(B1="","",OFFSET(Sheet1!L$2,(ROW(C1)-1)/5,))
範囲 A1:D1 を下方にズズーッとオートフィル

てのは如何？

この回答へのお礼

ありがとうございました！
簡単な式で希望通りのことができたので、ベストアンサーにさせていただきました。

お礼日時：2017/12/14 19:37

No.3 回答者： tom04 回答日時： 2017/12/13 20:19

続けておじゃまします。

No.2のコードで間違いがありました。

＞Range(wS.Cells(2, "A"), wS.Cells(lastRow, "K")).ClearContents
を
＞Range(wS.Cells(2, "A"), wS.Cells(lastRow, "L")).ClearContents
に変更してください。

Sheet2の最終列はK列ではなく、L列でしたね。

どうも失礼しました。m(_ _)m

この回答へのお礼

早急に回答いただいて、ありがとうございました！
私には高度だったのですが、挑戦してみます。

お礼日時：2017/12/14 19:40

No.2 回答者： tom04 回答日時： 2017/12/13 20:08

No.1です。

＞日付はバラバラなんです。。。

やっぱりそうだったんですかぁ～！

それでは手っ取り早くVBAでの一例です。
Sheet1のE列作業列は不要なので、削除してください。

↓のコードを標準モジュールに記載し、マクロを実行してみてください。
尚、質問文通り最大5種類とます。

Sub Sample1() '//この行から//
Dim myDic As Object
Dim myKey, myItem, myR, myAry, myAry2
Dim i As Long, k As Long, lastRow As Long
Dim myStr As String, wS As Worksheet

Set myDic = CreateObject("Scripting.Dictionary")
Set wS = Worksheets("Sheet2")

lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
If lastRow > 1 Then
Range(wS.Cells(2, "A"), wS.Cells(lastRow, "K")).ClearContents
End If
With Worksheets("Sheet1")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
myR = Range(.Cells(2, "A"), .Cells(lastRow, "D"))
For i = 1 To UBound(myR, 1)
myStr = myR(i, 1) & "_" & myR(i, 4)
If Not myDic.exists(myStr) Then
myDic.Add myStr, myR(i, 2) & "_" & myR(i, 3)
Else
myDic(myStr) = myDic(myStr) & "_" & myR(i, 2) & "_" & myR(i, 3)
End If
Next i
End With
myKey = myDic.keys
myItem = myDic.items
For i = 0 To UBound(myKey)
myAry = Split(myKey(i), "_")
myAry2 = Split(myItem(i), "_")
wS.Cells(i + 2, "A") = myAry(0)
wS.Cells(i + 2, "L") = myAry(1)
For k = 0 To UBound(myAry2)
wS.Cells(i + 2, k + 2) = myAry2(k)
Next k
Next i
Set myDic = Nothing
wS.Activate
MsgBox "完了"
End Sub '//この行まで//

※　データ変更があるたびにマクロを実行する必要があります。

※　日付順にソートが必要なのかもしれませんが、
今回は並び替えはしていません。m(_ _)m

No.1 回答者： tom04 回答日時： 2017/12/13 18:30

こんばんは！

日付に1日だけなのでしょうか？

一例です。
元データはSheet1にあり、Sheet2に表示するとします。

↓の画像のようにSheet1に作業用の列を設けています。
（これはA列を重複なしに表示させるため）

作業列E2セルに
=IF(COUNTIF(A$2:A2,A2)=1,ROW(),"")
という数式を入れフィルハンドルでこれ以上データはない！という位まで下へフィル＆コピーしておきます。

Sheet2のA2セルに
=IFERROR(INDEX(Sheet1!A:A,SMALL(Sheet1!E:E,ROW(A1))),"")

B2セルに
=IF($A2="","",IFERROR(INDEX(Sheet1!$B$1:$B$1000,SMALL(IF(Sheet1!$A$1:$A$1000=$A2,ROW($A$1:$A$1000)),INT(COLUMN()/2))),""))

配列数式なので、Ctrl＋Shift＋Enterで確定しておきます。

C2セルに
=IF($A2="","",IFERROR(INDEX(Sheet1!$C$1:$C$1000,SMALL(IF(Sheet1!$A$1:$A$1000=$A2,ROW($A$1:$A$1000)),INT(COLUMN(B1)/2))),""))

こちらも配列数式なので、Ctrl＋Shift＋Enterで確定！

B2・C2セルを範囲指定　→　C2セルのフィルハンドルで右へ2列ずつコピー！

最後にA2～K2セルを範囲指定　→　K2セルのフィルハンドルで下へコピーすると
画像のような感じになります。

※　最初に書いたように1日のデータしかないのであれば
日付列は簡単なので、手を付けていません。

※　日付がバラバラで日付ごとに分ける必要がある場合、
かなり面倒な数式になります。m(_ _)m