

元データのシート（写メ1参照）から、完成形のシート（写メ2参照）を抽出するマクロVBA を作成したいです。

作業手順を日本語にすることはできますが（写メ3参照）、  
マクロVBA でどのようなコードを書けばいいのかがわかりません。

詳しい方、どのようなコードを書けばいいのか、教えていただけると幸いです。  
また、良ければ、どのようにExcelVBAに精通したのか、勉強方法も教えていただけると幸いです。  
（今の私は、教科書的な一つ一つの作業（例.行と列を入れ替える、行と列を入れ替えたデータを別シートに抽出する、等）しかできず、実践の場では全く手が出ません。）

※追記  
teratail, Qiita にて、似た題名の質問をしていますが、内容は異なります。  
上記2サイトでは、本投稿での問題の簡易バージョンを質問しています。  
（アルファベットと数字の混在したデータを、桁ごとに昇順に並べる方法や、  
表を縦横変換した後、2つのデータの組を1つのデータの昇順に並び替える方法がわからなかったため、こちらで質問させていただきました。）

[![写メ1　元データのシート](https://i.stack.imgur.com/69CwE.png)](https://i.stack.imgur.com/69CwE.png)

[![写メ2　完成形のシート](https://i.stack.imgur.com/GTswO.png)](https://i.stack.imgur.com/GTswO.png)

[![写メ3　完成形の作り方（日本語）](https://i.stack.imgur.com/QLzOm.png)](https://i.stack.imgur.com/QLzOm.png)


CC BY-SA 4.0
2021-01-10T05:06:31.920
73183
2021-01-11T04:30:42.667
2021-01-10T05:51:56.333
43476
43476
question
vba excel
別シートに、行列を入れ替えたデータを抽出する方法について


この辺の記事を参考にして処理を作っていきます。

[指定した名前のシートが存在するかを確認する方法](https://bayashita.com/p/entry/show/192)  
[シートをコピーして名前を変更する方法](https://bayashita.com/p/entry/show/191)  
[第88回.並べ替え（Sort）](https://excel-ubara.com/excelvba1/EXCELVBA388.html)  
[縦持ちのデータを横持ちにする方法](https://oshiete.goo.ne.jp/qa/9485523.html)  
[操作の対象セル範囲が不定の場合](http://officetanaka.net/excel/vba/cell/cell10.htm)  
[最終行・最終列の取得方法（End,CurrentRegion,SpecialCells,UsedRange）](https://excel-
ubara.com/excelvba4/EXCEL222.html)

**(1)** の建物名ソートのルールは、普通の文字列ソートの考え方と一緒だと思われるので、特別な関数など作らずにEXCEL
VBAのソート機能で出来るでしょう。

データを配列として取り込んで、結果をシートに書き出す方が早いらしいですが、私自身はEXCEL
VBAの知識・経験に乏しいのでEXCELの機能を使う方向で作ってみました。  
[VBA 縦２列を横３列(それ以上に変更可)に変換したい](https://teratail.com/questions/120202)

[code]

    ' 処理のメイン
    Sub TransformTable()
        Dim i As Long, c As Range, wS As Worksheet
        Dim x As Long, h1 As String, h2 As String
        
        Application.ScreenUpdating = False  ' 作業途中の表示をOFF
        
        ' "横シート"が存在するなら削除
        If IsSheetExists("横シート") Then
            Application.DisplayAlerts = False
            Sheets("横シート").Delete
            Application.DisplayAlerts = True
        End If
        
        ' "縦シート"を作業シートにコピーしてソート
        Call Sheets("縦シート").Copy(After:=Sheets("縦シート"))
        ActiveSheet.Name = "WorkTemp"
        Set wS = ActiveSheet
        h1 = wS.Cells(1, "B") ' 列名の基を記憶
        h2 = wS.Cells(1, "C") ' 列名の基を記憶
        With wS.Sort
            With .SortFields
                .Clear
                .Add Key:=wS.Range("A1"), Order:=xlAscending   ' 建物名を昇順
                .Add Key:=wS.Range("C1"), Order:=xlDescending  ' 混雑割合を降順
            End With
            .SetRange wS.Range("A1").CurrentRegion
            .Header = xlYes
            .Apply
        End With
    
        ' "横シート"を作成し、作業シート内容を並び替えてコピー
        Call Sheets.Add(After:=Sheets("縦シート"))
        ActiveSheet.Name = "横シート"
        Set wS = ActiveSheet
        wS.Cells.ClearContents
        With Worksheets("WorkTemp")
            .Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS.Range("A1"), Unique:=True
            For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
                Set c = wS.Range("A:A").Find(what:=.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
                wS.Cells(c.Row, Columns.Count).End(xlToLeft).Offset(, 1) = .Cells(i, "B") ' 部屋(右方向に拡張して設定)
                wS.Cells(c.Row, Columns.Count).End(xlToLeft).Offset(, 1) = .Cells(i, "C") ' 混雑割合(上記に同じ)
            Next i
        End With
        
        ' データの存在する分だけ列名+番号を設定
        x = (wS.Range("A1").CurrentRegion.Columns.Count - 1) / 2
        For i = 1 To x
            wS.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1) = h1 + str(i) ' 部屋 + 列番号
            wS.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1) = h2 + str(i) ' 混雑割合 + 列番号
        Next i
    
        ' 作業シートを削除
        Application.DisplayAlerts = False
        Sheets("WorkTemp").Delete
        Application.DisplayAlerts = True
        
        Application.ScreenUpdating = True  ' 表示を再開
        wS.Activate
    
    End Sub
    
    ' 名前でシートが存在するかチェック
    Function IsSheetExists(strSheetName As String)
        Dim objWorksheet As Worksheet
        On Error GoTo NotExists
        
        Set objWorksheet = ThisWorkbook.Sheets(strSheetName)
        IsSheetExists = True
        Exit Function
    NotExists:
        IsSheetExists = False
    End Function
    
[/code]


CC BY-SA 4.0
2021-01-11T04:30:42.667
73205
2021-01-11T04:30:42.667
26370
73183
answer