こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

回答受付中の質問

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

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

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

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

投稿日時 - 2019-01-28 20:15:55

QNo.9582369

困ってます

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(5)

ANo.5

「縦並びに変換」表は別シート 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 を下方にズズーッと(3列ともに数値 0 が表示されるまで)オートフィル
以上の結果が添付図左です。

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

投稿日時 - 2019-01-29 00:01:32

ANo.4

商品の種類からすると、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

投稿日時 - 2019-01-28 23:09:37

ANo.3

関数よりもVBAの方が簡単。
例データ 
Sheet1AのA2: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 ’データは1万行以下と仮定
'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 ’次は1行下に書き出し
Next j
p1:
Next i
End Sub
ーーー
結果
Sheet2のA2:C13
Aレモン2
Bリンゴ12
Cババナ1
Cレモン1
Cリンゴ1
Cブドウ2
Dイチゴ2
Eキウイ5
Fパイナップル1
Fレモン2
Fリンゴ2
Fブドウ3

投稿日時 - 2019-01-28 21:58:25

ANo.2

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

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


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

投稿日時 - 2019-01-28 21:41:12

ANo.1

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

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

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

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

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

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

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

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

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

10.もともとの先頭行(Aさん、Bさん)をキーにして並べ替えます。

以上であります。

投稿日時 - 2019-01-28 20:48:31

あなたにオススメの質問