横並びデータを縦並びに変更

質問

左枠内のように並んでいるデータがあります。
氏名をキーとして商品と個数を右枠内のように、縦並びに変換したいです。

左枠内のデータは1000を超えると想定しておりますので
マクロで処理ができればと思っているのですが、
初心者のため、どういう風にマクロを組めばいいかわかりません。。。

ご教授いただければ幸いです。
どうぞよろしくお願いいたします。

回答No.5

msMike

「縦並びに変換」表は別シート Sheet2 に作成するものとします。

添付図左参照(判読困難御免)
A2: =OFFSET(Sheet1!B$3,(ROW(Sheet1!A1)-1)/4,)
B2: =OFFSET(Sheet1!C$3,(ROW(Sheet1!A1)-1)/4,MOD((ROW(Sheet1!A1)-1)*2,8))
セル B2 を右隣にオートフィル

範囲 A2:C2 を下方にズズーッと(３列ともに数値 0 が表示されるまで)オートフィル
以上の結果が添付図左です。

入力された任意のセルを選択 ⇒ Ctrl+G ⇒ [セル選択] ⇒ “アクティブ
セル領域”に目玉入れ ⇒ Ctrl+C ⇒ マウスの右クリック ⇒ [貼り付け
のオプション]直下の[値]アイコンをチョーン ⇒ B列全体を選択 ⇒
Ctrl+G ⇒ [セル選択] ⇒ “定数”に目玉入れ、および、“数値”以外の
チェック外し ⇒ [OK] ⇒ 選択された任意のセル上でマウスの右ク
リック ⇒ [削除] ⇒ “行全体”に目玉入れ ⇒ [OK]
以上の結果が添付図右です。

回答No.4

watabe007

商品の種類からすると、J列まで収まりそうでないので
縦並びはSheet2のB2セルに出力しました。
Sub Test()
　　Dim LastCol As Long, LastRow As Long
　　Dim v(), i As Long
　　Dim r As Long, c As Long

　　'最終行
　　LastRow = Range("B2").End(xlDown).Row
　　'最終列
　　LastCol = Range("B2").End(xlToRight).Column
　　For r = 3 To LastRow
　　　　For c = 3 To LastCol - 1 Step 2
　　　　　　If Cells(r, c).Value <> "" Then
　　　　　　　　i = i + 1
　　　　　　　　ReDim Preserve v(1 To 3, 1 To i)
　　　　　　　　v(1, i) = Cells(r, "B").Value
　　　　　　　　v(2, i) = Cells(r, c).Value
　　　　　　　　v(3, i) = Cells(r, c + 1).Value
　　　　　　End If
　　　　Next
　　Next
　　'出力をSheet2のB2セルに行いました
　　With Sheets("Sheet2")
　　　　.Range("B2:D2").Value = Array("氏名", "商品", "個数")
　　　　.Range("B3").Resize(UBound(v, 2), 3).Value = Application.Transpose(v)
　　End With
'　　出力をSheet2ではなく、M2セルに行うのなら下記をお使いください。
'　　Range("M2:O2").Value = Array("氏名", "商品", "個数")
'　　Range("M3").Resize(UBound(v, 2), 3).Value = Application.Transpose(v)
End Sub

回答No.3

imogasi

関数よりもVBAの方が簡単。
例データ　
Sheet1ＡのＡ2:I7　　画像の例と少し変えた
A レモン 2
B リンゴ 12
C ババナ 1 レモン 1 リンゴ 1 ブドウ 2
D イチゴ 2
E キウイ 5
F パイナップル 1 レモン 2 リンゴ 2 ブドウ 3
ーーー
標準モジュールに
Sub test01()
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
'--
lr = sh1.Range("a10000").End(xlUp).Row　’データは１万行以下と仮定
'MsgBox lr
k = 2
'--行方向繰り返し
For i = 2 To lr
'---列方向繰り返し
For j = 2 To 200 Step 2
If sh1.Cells(i, j) = "" Then GoTo p1　’その列（果物列）空白なら次行処理へ
’－‐データ編集　3列分
sh2.Cells(k, "A") = sh1.Cells(i, "A")
sh2.Cells(k, "B") = sh1.Cells(i, j)
sh2.Cells(k, "C") = sh1.Cells(i, j + 1)
’－－－
k = k + 1　’次は１行下に書き出し
Next j
p1:
Next i
End Sub
ーーー
結果
Ｓｈｅｅｔ２のＡ２：Ｃ１３
A レモン 2
B リンゴ 12
C ババナ 1
C レモン 1
C リンゴ 1
C ブドウ 2
D イチゴ 2
E キウイ 5
F パイナップル 1
F レモン 2
F リンゴ 2
F ブドウ 3

回答No.2

HohoPapa

こんな感じでいかがでしょうか？

※商品列数は４
　商品が必ずしも左詰で並んではいない前提です。

Option Explicit

Sub Sample()
　Const srow = 3　　'入力開始行
　Const scol = 3　　'商品開始列
　Const colcnt = 4　'商品列数

　Dim wkRow As Long
　Dim wkCol As Long
　Dim GetWS As Worksheet
　Dim PutWS As Worksheet
　Dim PutLine As Long

　Set GetWS = ThisWorkbook.Sheets(1)
　Set PutWS = ThisWorkbook.Sheets(2)

　PutLine = 2　　'出力先タイトル行

　PutWS.Cells(PutLine, 1).Value = "氏名"
　PutWS.Cells(PutLine, 2).Value = "商品"
　PutWS.Cells(PutLine, 3).Value = "個数"

　wkRow = srow
　Do
　　If GetWS.Cells(wkRow, scol - 1).Value = "" Then Exit Do
　　For wkCol = scol To colcnt * 2 + scol Step 2
　　　If GetWS.Cells(wkRow, wkCol).Value <> "" Then
　　　　PutLine = PutLine + 1
　　　　PutWS.Cells(PutLine, 1).Value = GetWS.Cells(wkRow, 2).Value
　　　　PutWS.Cells(PutLine, 2).Value = GetWS.Cells(wkRow, wkCol).Value
　　　　PutWS.Cells(PutLine, 3).Value = GetWS.Cells(wkRow, wkCol + 1).Value
　　　End If
　　Next wkCol
　　wkRow = wkRow + 1
　Loop

End Sub

回答No.1

noname#252332

マクロとか難しいことをしなくても、
１．今あるシートを、別のシート3つにコピーする。これで同じ内容のシートが4つできます。

２．2番目のシートのC,D列を削除して前につめます。元E,F,G,H,I,Jだったところが、新しいC,D,E,F,G,Hになって、I,Jは空白になります。

３．３番目のシートのC,D,E,F列を削除して前につめます。元G,H,I,Jだったところが、新しいC,D,E,Fになって、G,H、I,Jは空白になります。

４．４番目のシートのC,D,E,F,Ｇ,H列を削除して前につめます。元I,Jだったところが、新しいC,Dになって、E,F,G,H,I,Jは空白になります。

5.　４つのシートのE～J列をそれぞれ削除。

6．4つのシートをひとつのシートの上にコピーして一つのシートにまとめます。

７．C列を先頭にコピーします。並べ替えのキーにするためです。

８．先頭のレモン、リンゴなどをキーにして昇順に並べ替えます。そしてレモン、リンゴの列（C列）が空白の行をまとめて削除します。

９．さっきコピーしたC列と同じ内容の先頭の列を削除します。

１０．もともとの先頭行（Aさん、Bさん）をキーにして並べ替えます。

以上であります。