エクセルでデータ並び替え→別シートへ

質問

品名　　蜜柑　林檎　林檎　
　　サイズ　　大　 　小　 　 中　
店名　計
Ａ店　　４　　　２　　　　　　　２
Ｂ店　　６　　　　　　　３　　　３

というテキストがSeet1にあったとしてSeet2へ

店名　品名　サイズ　個数
Ａ店　蜜柑　　大　　　２
Ａ店　林檎　　中 　 　２
Ｂ店　林檎　　小 　 　３
Ｂ店　林檎　　中 　 　３

と並び替えるにはどうしたら良いのでしょうか？

回答No.11

Wendy02 · ベストアンサー

noverena　様

こんばんは。

返事が遅くなりました。時間が経つと、この規模のものになると、再び戻るまでにしばらく時間が掛かってしまいます。時間的には、数時間なのですが。
サイズの部分を対話式に切り替えました。良く注意して設定してください。

　　品名
　　サイズ1
　　サイズ2
　　サイズ3
店名　計
－データの始まり－

データの始まりを、サイズの終わりの次の次の行というように考えられていますので、その方式は守ってください。

コードはこの部分です。Sr は、サイズの行数です。
　Set r1 = .Range(.Cells(SizeArea.Row + Sr + 1, 1), .Range("A65536").End(xlUp))
このコードでややこしい部分は、貼り付け部分にあります。ある程度、慣れれば読みきれるかと思います。

ご自身で加工する場合は、なるべくひとかたまりにばらして、位置をキメウチして作ったほうが分りやすいです。以下のような書き方は、掲示板のみに存在する書き方で、実務的ではありません。ロジックそのものは、それほど複雑ではありません。

実際に、お客さんから、こちらの希望している形で入るということは限りませんから、その時の状況にマクロを編集するとなると、細かく分かれていたほうがよいです。また、配列変数を使うべきかどうかは、状況や慣れにもよりますが、ややこしくするだけだと思ったら、セル(Cells(i,j))型の対応で考えたほうが良いかもしれません。

'------------------------------------------------------

'<標準モジュール>
Sub ReArrangingListR2()
　 '再改良版
　 Dim DataAr()
　 Dim myDescript()
　 Dim mySize()
　 Dim DescriptArea As Range
　 Dim SizeArea As Range
　 Dim Sr As Integer 'サイズの行数
　 Dim Sl As Integer 'サイズの列数
　 Dim Sri As Integer 'サイズのカウンタ
　 Dim Slj As Integer　'サイズのカウンタ
　 Dim r1 As Range
　 Dim c As Range
　 Dim i As Long
　 Dim j As Long
　 Dim m As Long

　 Dim n As Integer
　 Dim k As Integer
　 Dim x As Integer
　 Dim Sh1 As Worksheet
　 Dim Sh2 As Worksheet
　 Dim Srx As Integer '品名変数のルー部
　 Dim LastCol As Integer
　 'シートの設定の登録
　 Set Sh1 = Worksheets("Sheet1")
　 Set Sh2 = Worksheets("Sheet2")
　 With Sh2.Range("A1").CurrentRegion
　　　If WorksheetFunction.CountA(.Cells) > 1 Then
　　　If MsgBox("前のデータを削除してよろしいですか？", vbOKCancel) = vbCancel _
　　　　 Then Exit Sub
　　　　 .ClearContents
　　　End If
　 End With

　 With Sh1
　　　'項目の部分の設定
　　　Set DescriptArea = .Range("C1", .Range("IV1").End(xlToLeft))
　　　If WorksheetFunction.CountA(DescriptArea) = 0 Then
　　　　 MsgBox "項目名が見つかりません。" & vbCrLf & _
　　　　 "項目エリアは、" & DescriptArea.Parent.Name & "の" & DescriptArea.Address & "に設定されています。", vbInformation
　　　　 Exit Sub
　　　End If
　　　For Each c In DescriptArea
　　　　 '品名の取得
　　　　 x = x + 1
　　　　 ReDim Preserve myDescript(1 To x)
　　　　 myDescript(x) = c.Value
　　　Next c
　　　Application.Goto .Range("A1")
　　　On Error Resume Next
SiZeAreaSet:
　　　Set SizeArea = Application.InputBox("サイズの領域を設定してください" & vbCrLf & "必ず品名の下の行から店名の手前までを選択してください。", "サイズの取得", Type:=8)
　　　If SizeArea Is Nothing Then
　　　　 MsgBox "範囲を取得していません。", vbInformation
　　　　 If MsgBox("再度続けますか?", vbOKCancel) = vbCancel Then
　　　　　　Exit Sub
　　　　 End If
　　　　 GoTo SiZeAreaSet
　　　End If
　　　On Error GoTo 0
　　　Application.ScreenUpdating = False
　　　Sr = SizeArea.Rows.Count
　　　Sl = SizeArea.Columns.Count - 1
　　　ReDim mySize(1 To Sl, 1 To Sr)
　　　'サイズの取得
　　　For Slj = 1 To Sl
　　　　 For Sri = 1 To Sr
　　　　　　mySize(Slj, Sri) = SizeArea.Offset(, 1).Cells(Sri, Slj).Value
　　　　 Next Sri
　　　Next Slj

　　　'データ範囲
　　　Set r1 = .Range(.Cells(SizeArea.Row + Sr + 1, 1), .Range("A65536").End(xlUp))
　　　For i = 1 To r1.Rows.Count
　　　　 ReDim Preserve DataAr(DescriptArea.Columns.Count, i)
　　　　 For n = 0 To DescriptArea.Columns.Count
　　　　　　If n = 0 Then
　　　　　　　 DataAr(n, i - 1) = r1.Cells(i, n + 1)
　　　　　　　 Else
　　　　　　　 DataAr(n, i - 1) = r1.Cells(i, n + 2)
　　　　　　End If
　　　　 Next n
　　　Next i
　 End With

　 With Sh2
　　　'次のシートへのデータの貼り付け
　　　'タイトル
　　　.Range("A1:B1").Value = Array("店名", "品名")
　　　.Range("C1").Resize(, Sr).Value = WorksheetFunction.Transpose(SizeArea.Resize(, 1).Value)
　　　.Range("IV1").End(xlToLeft).Offset(, 1).Value = "数量"
　　　LastCol = .Range("IV1").End(xlToLeft).Column
　　　m = 2 'Sh2の行の初期値
　　　For j = LBound(DataAr, 2) To UBound(DataAr, 2)
　　　　 For k = 1 To DescriptArea.Columns.Count
　　　　　　If DataAr(k, j) <> Empty Then
　　　　　　　 .Cells(m, 1).Value = DataAr(0, j)
　　　　　　　 .Cells(m, 2).Value = myDescript(k)
　　　　　　　 For Srx = 1 To Sr
　　　　　　　　 .Cells(m, 3).Cells(, Srx).Value = mySize(k, Srx)
　　　　　　　 Next
　　　　　　　 .Cells(m, LastCol).Value = DataAr(k, j)

　　　　　　　 m = m + 1
　　　　　　　 If m > Sh2.Columns(1).Cells.Count - 1 Then
　　　　　　　　　Application.ScreenUpdating = True
　　　　　　　　　MsgBox "Excel の最大行数を超えようとしていますので、中止します。" & vbCrLf & _
　　　　　　　　　"データを切り分けてください。", vbInformation
　　　　　　　　　Exit Sub
　　　　　　　 End If
　　　　　　End If
　　　　 Next k
　　　Next j
　 End With
　 Application.Goto Sh2.Range("A1")
　 Application.ScreenUpdating = True
　 Set r1 = Nothing: Set Sh1 = Nothing
　 Set Sh2 = Nothing: Set DescriptArea = Nothing
　 MsgBox "終了!"
End Sub

お礼

Wendy様

本当にいろいろ有難うございます！
こんなに親切な方に出会えて感激しています！

この度は本当に有難うございました。

回答No.10

Wendy02

noverena様

分りました。それほど、大した変更ではないようですね。ほっとしました。
ただ、本日(2/8)は、少し、お休みさせていただきます。

＞☆臨機応変に対応出来るマクロを作成。
＞後者の方は私の力では到底無理なので・・・

この件については、もう一度、見直してみます。

無理とかではなくて、経験的なものなのです。掲示板なんかですと、ユーザーフレンドリのコードって、めったに出会わないのです。いくつかのパターンをメモして寄せ集めていけばよいのですね。

余談ですが、お仕事は大変ですね。

お礼

Wendy様

お返事有難うございます。
本当に勉強になります。
今後とも宜しくお願い致します。

回答No.9

Wendy02

noverena様
こんにちは。Wendy02です。

＞現在2行目にサイズが有りますが
＞３行目、４行目とサイズ欄を増やす場合はコードのどの部分を修正及び追加すればよいのでしょうか？

以下のようなことですか？

　　品名　　蜜柑　林檎　林檎　
　　サイズ　　大　 　小　 　 中　
　　サイズ　　丸　 　四　 　 三　
　　サイズ　　長　 　短　 　 中長　
店名　計
Ａ店　　４　　　２　　　　　　　２
Ｂ店　　６　　　　　　　３　　　３

でも、そうすると、移し変えると、その表示が出来ませんね。
どのようになるのですか？

補足

いつも貴重なお時間を割いて頂き有難うございます。

下記のようなデータだと
品名　　蜜柑　林檎　林檎　
　　サイズ1　　大　 　小　 　 中　
　　サイズ2　　○　 　△　 　 ◇　
　　サイズ3　　☆　 　★　 　 ＊　
店名　計
Ａ店　　４　　　２　　　　　　　２
Ｂ店　　６　　　　　　　３　　　３

下記のように単にサイズの項目を横へ増やすという事です。
店名　品名　サイズ1　サイズ2　サイズ3　数量
Ａ店　蜜柑　大　　　　○　　　　☆　　　2
Ａ店　林檎　中　　　　◇　　　　＊　　　2
Ｂ店　林檎　小　　　　△　　　　★　　　3
Ｂ店　林檎　中　　　　◇　　　　＊　　　3

サイズ欄は時として変動する事がある為(行の増減)その場合の対応として、
☆最初から抽出項目を増やした状態にする。
☆臨機応変に対応出来るマクロを作成。

前者の方はWendy様のアドバイスで私にも出来るかと思いまして
後者の方は私の力では到底無理なので・・・

伝わりましたでしょうか？？？

回答No.8

Wendy02

こんばんは。Wendy02です。

マクロを直しました。横に広がっても自動的にデータを取得するようにしました。細かい点も修正しました。（データの上書き,データの場所が違う時,Excelの行数が越えてしまいそうな時のメッセージ,前回よりも、出力が多少速くするようにコードの修正)

フォームのボタンへは、マクロ名にR をつけましたので、再度登録しなおしてください。

'<標準モジュール>
Sub ReArrangingListR()
'改良版
Dim DataAr()
Dim myDescript()
Dim mySize()
Dim OutAr()
Dim DescriptArea As Range
Dim r1 As Range
Dim c As Range
Dim i As Long
Dim j As Long
Dim m As Long

Dim n As Integer
Dim k As Integer
Dim x As Integer
Dim y As Integer
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet

'シートの設定の登録
Set Sh1 = Worksheets("Sheet1")
Set Sh2 = Worksheets("Sheet2")
With Sh2.Range("A1").CurrentRegion
　If WorksheetFunction.CountA(.Cells) > 1 Then
　If MsgBox("前のデータを削除してよろしいですか？", vbOKCancel) = vbCancel _
　　Then Exit Sub
　　.ClearContents
　End If
End With
Application.ScreenUpdating = False

With Sh1
'項目の部分の設定
Set DescriptArea = .Range("C1", .Range("IV1").End(xlToLeft))
　 If WorksheetFunction.CountA(DescriptArea) = 0 Then
　　 MsgBox "項目名が見つかりません。" & vbCrLf & _
　　 "項目エリアは、" & DescriptArea.Parent.Name & "の" & DescriptArea.Address & "に設定されています。", vbInformation
　　 Exit Sub
　 End If
For Each c In DescriptArea
'品名の取得
　x = x + 1
　ReDim Preserve myDescript(1 To x)
　myDescript(x) = c.Value
Next c
For Each c In DescriptArea.Offset(1)
'サイズの取得
　y = y + 1
　ReDim Preserve mySize(1 To y)
　mySize(y) = c.Value
Next c

'データ範囲(A4～)
Set r1 = .Range("A4", .Range("A65536").End(xlUp))
For i = 1 To r1.Rows.Count
　ReDim Preserve DataAr(DescriptArea.Columns.Count, i)
　For n = 0 To DescriptArea.Columns.Count
　　If n = 0 Then
　　　　DataAr(n, i - 1) = r1.Cells(i, n + 1)
　　Else
　　　　DataAr(n, i - 1) = r1.Cells(i, n + 2)
　　End If
　Next n
Next i
End With

　With Sh2
　'次のシートへのデータの貼り付け
　'タイトル
　.Range("A1:D1").Value = Array("店名", "品名", "サイズ", "個数")
　m = 2 'Sh2の行の初期値
　ReDim OutAr(1 To 4) '出力バッファ
　For j = LBound(DataAr, 2) To UBound(DataAr, 2)
　　For k = 1 To DescriptArea.Columns.Count
　　　If DataAr(k, j) <> Empty Then
　　　　　OutAr(1) = DataAr(0, j)　'店名
　　　　　OutAr(2) = myDescript(k)
　　　　　OutAr(3) = mySize(k)
　　　　　OutAr(4) = DataAr(k, j)
　　　　　.Cells(m, 1).Resize(, 4).Value = OutAr()
　　　　　m = m + 1
　　　　　If m > Sh2.Columns(1).Cells.Count - 1 Then
　　　　　 Application.ScreenUpdating = True
　　　　　 MsgBox "Excel の最大行数を超えようとしていますので、中止します。" & vbCrLf & _
　　　　　 "データを切り分けてください。", vbInformation
　　　　　 Exit Sub
　　　　　End If
　　　End If
　　Next k
　Next j
　End With
　Application.Goto Sh2.Range("A1")
　Application.ScreenUpdating = True
　Set r1 = Nothing: Set Sh1 = Nothing
　Set Sh2 = Nothing: Set DescriptArea = Nothing
　MsgBox "終了!"
End Sub

補足

Wendy02様
遅くなりましたがご回答有難うございます。
すごいです完璧です！

そこで最後にひとつだけ質問です(当初の質問からかなり発展してしまいまして申し訳ありません。)
現在2行目にサイズが有りますが
３行目、４行目とサイズ欄を増やす場合はコードのどの部分を修正及び追加すればよいのでしょうか？

回答No.7

Wendy02

こんにちは。Wend02です。

＞SHEET1のF列以降に品名などを増やしたい場合は
＞コードのどの部分を書き換えればよいのでしょうか？

やっぱり、キメウチはダメでした。(;_;)
1列や2列じゃないですよね。今、チェックしてみましたが、#1のコードは、ある意味、手抜きしてありますので、本格的なものは、全面的な修正を施さなくてはなりません。しばらくお待ちください。もう一度書き直します。

回答No.6

Wendy02

noverena様へ　Wendy02です。

＞現在使用している実際のデータは、お店100店舗、品名・規格を合わせて150種類以上、
＞合計個数3000個以上のかなり大きなデータとなっております。
＞実際使用するのであればやはりマクロを使用したほうが良いのでしょうか？

それは、最初に書かれたほうが良かったですね。（^^;
その言葉があれば、文句なくマクロだと思います。関数は無理かな？できるとは言っても、ワークシートが重過ぎますから手順が増えます。

あまりのデータで、きっとどうしようもないから、質問されているわけだったのですね。

私のマクロでも、きっと遅いと思います。（気にはなったけれども、そのままにしてしまいました。もう少し深読みすれば気が付いたのですが。）

実践でやってみて、気になるようでしたら、コードを書き換えます。遠慮なく、おっしゃってくださいね。

補足

Wendy02様
本当にいつも有難うございます。

SHEET1のF列以降に品名などを増やしたい場合は
コードのどの部分を書き換えればよいのでしょうか？

質問だらけでごめんなさい・・・

回答No.5

NNAQ

Sheet1 A4に「Ａ店」が入力してあるとします。

Sheet2 A2 =Sheet1!A4
Sheet2 A3 =IF(COUNTIF($A2:A2,A2)=COUNT(INDEX(Sheet1!C:E,MATCH(A2,Sheet1!A:A,0),0)),INDEX(Sheet1!A:A,MATCH(A2,Sheet1!A:A,0)+1),A2)
下へコピー

Sheet2 B2 =INDEX(Sheet1!$C$1:$E$1,0,SMALL(IF(OFFSET(Sheet1!$C$1:$E$1,MATCH($A2,Sheet1!$A:$A,0)-1,0)>0,COLUMN($A:$C)),COUNTIF($A$2:$A2,$A2)))
配列数式　Ctrl + Shift + Enter で確定
下へコピー

Sheet2 C2 =INDEX(Sheet1!$C$2:$E$2,0,SMALL(IF(OFFSET(Sheet1!$C$1:$E$1,MATCH($A2,Sheet1!$A:$A,0)-1,0)>0,COLUMN($A:$C)),COUNTIF($A$2:$A2,$A2)))
B列の「INDEX(Sheet1!$C$1:$E$1」を「INDEX(Sheet1!$C$2:$E$2」に変えただけ。
配列数式　Ctrl + Shift + Enter で確定
下へコピー

Sheet2 D2 =INDEX(Sheet1!C:E,MATCH(A2,Sheet3!A:A,0),SMALL(IF(OFFSET(Sheet1!$C$1:$E$1,MATCH($A2,Sheet1!$A:$A,0)-1,0)>0,COLUMN($A:$C)),COUNTIF($A$2:$A2,$A2)))
配列数式　Ctrl + Shift + Enter で確定
下へコピー

店名　品名　サイズ　個数
Ａ店　蜜柑　　大　　　２
Ａ店　林檎　　中 　 　２
Ｂ店　林檎　　小 　 　３
Ｂ店　林檎　　中 　 　３
　0　　#N/A　　#N/A　　#N/A
各列6行目までコピーすると、こうなると思います。

回答No.4

Wendy02

こんばんは。Wendy02です。

＞ごめんなさい。フォームのボタンって何でしょうか？

フォームツールバーが出てきたら、ボタンをクリック

ワークシート上でドラッグ－ボタン状に変ったら

マクロの登録

マクロ名を探してクリック

---------
今回、たまたまいろんなレスがついちゃったようですが、

単にここのカテゴリだけでも、このご質問に似たものは多いです。マクロを知らない人には解決できないので、結構、困ってしまいます。必ずしもピボットで解決できるとも限りませんしね。ただ、私は、VBAの典型的な問題のような気がしましたが、#3のimogasiさんが回答なさっている方法も良いかもしれませんね。確かに、個数0を抜きさえすればよいわけですからね。

お礼

有難うございます！出来ました。
ＶＢＡはこれから勉強してゆきたいと思います。
このたびは本当に有難うございました！

回答No.3

imogasi

関数でやって見ます。
個数０を一旦出さないようにするには多分絶望的。
とりあえず、０も出します。・
例データ
Ｓｈｅｅｔ２の
Ａ１：Ｅ７
品名 蜜柑 林檎 林檎
サイズ 大 小 中
店名 計
Ａ店 4 2 2
Ｂ店 6 3 3
Ｃ店 6 1 5
Ｄ店 12 4 2 6
Ｓｈｅｅｔ３のＡ１に
=INDEX(Sheet2!$A$1:$E$100,INT((ROW()-1)/3)+4,COLUMN())
と入れて、Ａ１２まで、式を複写する。
Ｂ１に
=INDEX(Sheet2!$A$1:$E$100,1,MOD((ROW()-1),3)+3)
といれてＢ１２まで式を複写する。
Ｃ１に
=INDEX(Sheet2!$A$1:$E$100,2,MOD((ROW()-1),3)+3)
と入れてＣ１２まで式を複写する。
Ｄ１に
=INDEX(Sheet2!$A$1:$E$100,INT((ROW()-1)/3)+4,MOD((ROW()-1),3)+3)
と入れてＤ１２まで式を複写する。
結果
Ａ店 蜜柑 大 2
Ａ店 林檎 小 0
Ａ店 林檎 中 2
Ｂ店 蜜柑 大 3
Ｂ店 林檎 小 3
Ｂ店 林檎 中 0
Ｃ店 蜜柑 大 1
Ｃ店 林檎 小 5
Ｃ店 林檎 中 0
Ｄ店 蜜柑 大 4
Ｄ店 林檎 小 2
Ｄ店 林檎 中 6
もし個数０の行を省くなら、結果を値（コピーー形式を選択して貼り付けー値）にして、個数でソートし
０の行を削除する。
そのままソートしないこと。
順番が崩れるので、ソートする前に、行の番号を振っておいて、０の行をを削除後、振った番号で並べ替えて元に戻すこと

お礼

回答有難うございます。
関数でも出来るのですね！大変参考になりました。
現在使用している実際のデータは、お店100店舗、品名・規格を合わせて150種類以上、合計個数3000個以上のかなり大きなデータとなっております。
実際使用するのであればやはりマクロを使用したほうが良いのでしょうか？

回答No.2

cockerel

どうも元のデータが計画的に設計されていないような気がします。
自動処理は、システマチックなデータに適しており、人間味のあふれたデータをあまり得意としません（質問の内容の変換だけであれば、場当たり的に行うことは可能と思われますが、ほかにも類似の定義の曖昧性が含まれていると考えられます）。
このような場合、まず、元のデータを設計し直すことから始めた方が誤りがないと思われます。またそのような癖を付けておくと、今後はピボットテーブル等で簡単に整理することができるようになります。
がんばってください。

お礼

回答していただき有難うございます。
このデータが私どもの管理している物ならいいのですが、お客様が使用しているシステムデータの為設計見直しを依頼してという方向にはなかなか・・・
場当たり的な方法だけでもお教え頂けないでしょうか？

回答No.1

Wendy02

こんにちは。

ご質問のような内容の場合は、たぶん、VBAの処理ぐらいしかないだろうと思います。VBAの内容としては、基本的なものにしましたが、ちょっと、ややこしいですね。

以下のコードの取り付け方:

Alt　+　 F11 (Altを押しながらF11）を押すと、Visual Basic Editor 画面が出てきます。
次に、メニューの[挿入]－[標準モジュール]と開けて、クリックすると、画面が現れますので、以下のコードを貼り付けて、Alt　+　Q で、画面を閉じます。

後は、フォームのボタンなどに取り付けると良いかと思います。

'<標準モジュール>
Sub ReArrangingList()
Dim DataAr()
Dim myDescript(1 To 3)
Dim mySize(1 To 3)
Dim r1 As Range
Dim c As Range
Dim i As Long
Dim j As Long
Dim m As Long

Dim k As Integer
Dim x As Integer
Dim y As Integer
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet

'シートの設定の登録
Set Sh1 = Worksheets("Sheet1")
Set Sh2 = Worksheets("Sheet2")

Application.ScreenUpdating = False

With Sh1
For Each c In .Range("C1:E1")
'品名の取得
　x = x + 1
　myDescript(x) = c.Value
Next c
For Each c In .Range("C2:E2")
'サイズの取得
　y = y + 1
　mySize(y) = c.Value
Next c

'データ範囲(A4～)
Set r1 = .Range("A4", .Range("A65536").End(xlUp))
For i = 1 To r1.Rows.Count
　ReDim Preserve DataAr(3, i)
　DataAr(0, i - 1) = r1.Cells(i, 1)
　DataAr(1, i - 1) = r1.Cells(i, 3)
　DataAr(2, i - 1) = r1.Cells(i, 4)
　DataAr(3, i - 1) = r1.Cells(i, 5)
Next i
End With

　With Sh2
　'次のシートへのデータの貼り付け
　'タイトル
　.Range("A1:D1").Value = Array("店名", "品名", "サイズ", "個数")
　m = 2 'Sh2の行の初期値
　For j = LBound(DataAr, 2) To UBound(DataAr, 2)
　　For k = 1 To 3
　　　If DataAr(k, j) <> Empty Then
　　　　 .Cells(m, 1).Value = DataAr(0, j) '店名
　　　　 .Cells(m, 2).Value = myDescript(k)
　　　　 .Cells(m, 3).Value = mySize(k)
　　　　 .Cells(m, 4).Value = DataAr(k, j)
　　　　　m = m + 1
　　　End If
　　Next k
　Next j
　End With
　Application.ScreenUpdating = True
　Set r1 = Nothing: Set Sh1 = Nothing: Set Sh2 = Nothing

End Sub

お礼

回答して下さいまして有難うございます。
早速試してみます！

補足

＞後は、フォームのボタンなどに取り付けると良いかと思います。

ごめんなさい。フォームのボタンって何でしょうか？