種類ごとに横に並んだ数字を別シートに縦に変換する方法を教えて下さい

質問

エクセルシートで、Ｓｈｅｅｔ１に種類ごとに横に並んだ数字があり、そのデータをＳｈｅｅｔ２の指定のセルに数字の小さい順に縦に並び替えしたいのですが、どのようなＶＢＡを書込んだら可能でしょうか？ご教授願います。

例
Ｓｈｅｅｔ１
　Ａ　　　　Ｂ　　　　Ｃ　　　　Ｄ　　　　Ｅ　　　　Ｆ　　　　Ｇ
１
２　　　　　りんご　 ８　　　　３　　　　１２
３　　　　　みかん　２　　　　９
４　　　　　バナナ　４　　　　３　　　　７
５
６

　このデータを下記のように変更して貼り付け

Ｓｈｅｅｔ２
　Ａ　　　　Ｂ　　　　Ｃ　　　　Ｄ　　　　Ｅ　　　　Ｆ　　　　Ｇ
１
２
３　　　　　　　　　　　りんご　 ３
４　　　　　　　　　　　　　　　 　８
５　　　　　　　　　　　　　　　　１２
６　　　　　　　　　　　みかん　 ２
７　　　　　　　　　　　　　　　　 ９
８　　　　　　　　　　　バナナ　 ３
９　　　　　　　　　　　　　　　 　４
１０　　　　　　　　　　　　　 　　７
１１

回答No.2

merlionXX · ベストアンサー

面白そうなのでやってみました。
ただ、例示のセルの配置がよくわからないのでSheet1のりんご等はA列に
数値はB列から右へあるものとし、Sheet2のA1以下に転記するようにしました。
品名の列や数値の行に途中の空白セルはないものとします。
数値データで同一値や数値外のものもないものとします。（つまりエラーチェックはしてませんよ）

Sub test()
Dim St1 As Worksheet, St2 As Worksheet
Dim sRng As Range, c As Range
Dim i As Long, n As Long
Set St1 = Worksheets("Sheet1")
Set St2 = Worksheets("Sheet2")
With St1
i = 1
For Each c In .Range(.Range("A1"), .Range("A1").End(xlDown))
Set sRng = .Range(c.Offset(0, 1), c.Offset(0, 1).End(xlToRight))
St2.Cells(i, "A").Value = c.Value
For n = 1 To sRng.Count
St2.Cells(i, "A").Offset(0, 1).Value = Application.WorksheetFunction.Small(sRng.Value, n)
i = i + 1
Next n
Set sRng = Nothing
Next c
End With
Set St1 = Nothing
Set St2 = Nothing
End Sub

お礼

最終行のバナナに入力された数字が４．３．７と三つありますが、３．７の二つを消して４だけで実行すると、「WorksheetFunctionクラスのSmallプロパティを取得できません」との実行時エラー１００４が出てしまいました。複数以上を入力して利用したいと思います。ありがとうございました。

回答No.4

mitarashi

無理矢理辻褄を合わせた、すっきりしないコードですが、ご参考まで。
シート内の配置がわかりにくいですが、Sheet1はB2から、Sheet2はC3からと判断して記述しています。
Sub test()
Dim targetRange As Range, destrange As Range
Dim myCell As Range, srcRange As Range

Set destrange = Sheets("Sheet2").Range("c3")
With Sheets("Sheet1")
Set targetRange = .Range(.Range("b2"), .Range("b" & .Rows.Count).End(xlUp))
End With
For Each myCell In targetRange
Set srcRange = Range(myCell.Offset(0, 1), myCell.Offset(0, 1).End(xlToRight))
myCell.Copy destrange
srcRange.Copy
destrange.Offset(0, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
destrange.Offset(0, 1).Resize(srcRange.Cells.Count, 1).Sort Key1:=destrange.Offset(0, 1), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
Set destrange = destrange.Offset(srcRange.Cells.Count, 0)
Next myCell
End Sub

お礼

Sheet１からSheet２へデータの貼付けを行うと、データ量が多くてもスムーズに処理が行われとても便利に使わせていただきました。ありがとうございました。あと、「りんご」「みかん」「バナナ」が貼り付いたところの書式が消えてしまうので、空白で入力するようにしました。

回答No.3

mt2008

違うアプローチで。
こういう形↓で良いなら簡単ですが。駄目でしょうか？

りんご みかん バナナ
　3　　　　2　　　3
　8　　　　9　　　4
　12　　　　　　　7

1.Sheet1のB2:E4をコピー
2.Sheet2のセルを選択
3.［形式を選択して貼り付け］で行列を入れ替えて貼り付ける
4.各列毎に［データ］-［並べ替え］で昇順にソート

マクロにしたいのでしたら上記の手順をマクロ記録で……。

お礼

これからは、さらにＶＢＡの勉強をしたいと考えております。ありがとうございました。

回答No.1

daketa2

かなり練らないと答え出ませんね。。。
ちょっと問題丸投げしすぎじゃないでしょうか？

ちなみにソートがなければ以下のような感じで
作ったら出来ますよね？
ここから発展しそう。。。

Dim i As Long 'sheet1の横
Dim j As Long 'sheet1の縦
Dim k As Long 'sheet2の縦

i = 1
j = 1
k = 1

Do While Worksheets("sheet1").Cells(j, i).Value <> ""
Worksheets("sheet2").Cells(k, 1).Value = Worksheets("sheet1").Cells(j, i).Value
i = i + 1
Do While Worksheets("sheet1").Cells(j, i).Value <> ""
Worksheets("sheet2").Cells(k, 2).Value = Worksheets("sheet1").Cells(j, i).Value
i = i + 1
k = k + 1
Loop
i = 1
j = j + 1
Loop

お礼

ＶＢＡは素人で技術もありませんので、頂いた回答を参考に勉強いたいと思います。ありがとうございました。