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

Question

エクセルシートで、Ｓｈｅｅｔ１に種類ごとに横に並んだ数字があり、そのデータをＳｈｅｅｔ２の指定のセルに数字の小さい順に縦に並び替えしたいのですが、どのようなＶＢＡを書込んだら可能でしょうか？ご教授願います。

例
Ｓｈｅｅｔ１
　Ａ　　　　Ｂ　　　　Ｃ　　　　Ｄ　　　　Ｅ　　　　Ｆ　　　　Ｇ
１
２　　　　　りんご　 ８　　　　３　　　　１２
３　　　　　みかん　２　　　　９
４　　　　　バナナ　４　　　　３　　　　７
５
６

　このデータを下記のように変更して貼り付け

Ｓｈｅｅｔ２
　Ａ　　　　Ｂ　　　　Ｃ　　　　Ｄ　　　　Ｅ　　　　Ｆ　　　　Ｇ
１
２
３　　　　　　　　　　　りんご　  ３
４　　　　　　　　　　　　　　　 　８
５　　　　　　　　　　　　　　　　１２
６　　　　　　　　　　　みかん　 ２
７　　　　　　　　　　　　　　　　 ９
８　　　　　　　　　　　バナナ　 ３
９　　　　　　　　　　　　　　　 　４
１０　　　　　　　　　　　　　 　　７
１１

merlionXX · Accepted Answer

面白そうなのでやってみました。
ただ、例示のセルの配置がよくわからないので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

daketa2 · Answer

かなり練らないと答え出ませんね。。。ちょっと問題丸投げしすぎじゃないでしょうか？ちなみにソートがなければ以下のような感じで作ったら出来ますよね？ここから発展しそう。。。 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

mt2008 · Answer

違うアプローチで。
こういう形↓で良いなら簡単ですが。駄目でしょうか？

りんごみかんバナナ
　3　　　　2　　　3
　8　　　　9　　　4
　12　　　　　　　7


1.Sheet1のB2:E4をコピー
2.Sheet2のセルを選択
3.［形式を選択して貼り付け］で行列を入れ替えて貼り付ける
4.各列毎に［データ］-［並べ替え］で昇順にソート

マクロにしたいのでしたら上記の手順をマクロ記録で……。

mitarashi · Answer

無理矢理辻褄を合わせた、すっきりしないコードですが、ご参考まで。
シート内の配置がわかりにくいですが、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

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

かなり練らないと答え出ませんね。

面白そうなのでやってみました。

違うアプローチで。

無理矢理辻褄を合わせた、すっきりしないコードですが、ご参考まで。

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング