VBA100本ノック 36本目：列の並べ替え

公開日：2020-11-30　最終更新日：2021-02-22

VBA100本ノック 36本目：列の並べ替え

列見出しの()内の数値で列を並べ替える問題です。

ツイッター連動企画です。
ツイートでの見やすさを考慮して、ブック・シート指定等を適宜省略しています。

VBAテスト用のサンプルデータは、VBA100本ノックの目次ページ からもダウンロードできます。

マクロVBAを初心者向けの基本から上級者向けの高度な内容までサンプルコードを掲載し解説しています。エクセル関数・機能・基本操作の入門解説からマクロVBAまでエクセル全般を網羅しています。

出題

#VBA100本ノック 36本目
1行目の見出しの後ろには半角括弧()の中に数値が入っています。
この()括弧内の数値の昇順で列を並べ替えてください。
・全ての列に数値の入った()が正しく最後についています。
・数値は1~3桁の正の整数です。
※非表示列はありません。
※シートは任意

サンプルファイルです。
https://excel-ubara.com/vba100sample/VBA100_36.xlsm
https://excel-ubara.com/vba100sample/VBA100_36.zip

VBA作成タイム

この下に頂いた回答へのリンクと解説を掲載しています。
途中まででも良いので、できるだけ自分でVBAを書いてみましょう。

他の人の回答および解説を見て、書いたVBAを見直してみましょう。

頂いた回答

出題ツイートの引用ツイートでの回答

解説

100本ノックで並べ替えは2本目です。
前回はシートの並べ替えでした。
その時のバブルソートがそのまま使えます。
キーの取り出しは関数にしています。
数値化ではVal関数を使用しました。後ろの数値以外を無視してくれます。


  
    
      Sub VBA100_36_01()

　　Dim ws As Worksheet

　　Dim maxCol As Long

　　Set ws = ActiveSheet

　　maxCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

　　

　　Application.ScreenUpdating = False

　　

　　Dim i As Long, j As Long

　　For i = maxCol To 1 Step -1

　　　　For j = 1 To i - 1

　　　　　　If getSortKey(ws.Cells(1, j)) > getSortKey(ws.Cells(1, j + 1)) Then

　　　　　　　　ws.Columns(j + 1).Cut

　　　　　　　　ws.Columns(j).Insert

　　　　　　End If

　　　　Next

　　Next

　　

　　Application.ScreenUpdating = True

      End Sub


Function getSortKey(ByVal arg As String) As Long

      　　getSortKey = Val(Mid(arg, InStrRev(arg, "(") + 1))

End Function

列の並べ替えなら、行（横）方向にキーがあればエクセルの機能として列の並べ替えが使えます。
キーの取り出しは、先のFunctionをそのまま使います。
表範囲のすぐ下にキー値を出力し、その行の値で列方向に並べ替えしています。


  
    
      Sub VBA100_36_02()

　　Dim ws As Worksheet

　　Dim keyRng As Range

　　Set ws = ActiveSheet

　　With ws.Range("A1").CurrentRegion

　　　　Set keyRng = .Offset(.Rows.Count).Resize(1)

　　End With

　　

　　Application.ScreenUpdating = False

　　

　　Dim i As Long

　　For i = 1 To keyRng.Count

　　　　keyRng(i).Value = getSortKey(ws.Cells(1, i))

　　Next

　　

　　With ws.Sort

　　　　.SortFields.Clear

　　　　.SortFields.Add Key:=keyRng, _

　　　　　　　　　　　　SortOn:=xlSortOnValues, _

　　　　　　　　　　　　Order:=xlAscending

　　　　.SetRange ws.Range("A1").CurrentRegion

　　　　.Header = xlNo

　　　　.Orientation = xlLeftToRight

　　　　.Apply

　　End With

　　

　　keyRng.ClearContents

　　Application.ScreenUpdating = True

End Sub

今回は3桁以内という制限を付けました。
数値の範囲が制限されているなら、いわゆるバケットソートも使えます。
また、365ならシート関数のSortByを使う事も出来ます。
これらのVBAは記事補足に掲載しました。

補足

上記も含めて4通り作成しました。

・バブルソート
・エクセル機能の並べ替え
・バケットソート
・シートのSortBy関数

どれも一長一短がありますが、処理速度としては列の入れ替えにかかる時間が大きいです。
エクセル機能の並べ替えを使う方法が処理速度的には有利だと思います。

以下、キーの取り出しは先のFunctionをそのまま使います。
Function getSortKey

バケットソート


  
    
      Sub VBA100_36_03()

　　Dim ws As Worksheet

　　Dim maxCol As Long

　　Set ws = ActiveSheet

　　maxCol = ws.Range("A1").CurrentRegion.Columns.Count

　　

　　Application.ScreenUpdating = False

　　

　　Dim i As Long

      　　Dim ary() As Collection

　　ReDim ary(999)

　　For i = 1 To maxCol

　　　　If ary(getSortKey(ws.Cells(1, i))) Is Nothing Then

　　　　　　Set ary(getSortKey(ws.Cells(1, i))) = New Collection

　　　　End If

　　　　ary(getSortKey(ws.Cells(1, i))).Add ws.Columns(i)

　　Next

　　

　　Dim col As Range

　　For i = 1 To 999

　　　　If Not ary(i) Is Nothing Then

　　　　　　For Each col In ary(i)

　　　　　　　　col.Cut

　　　　　　　　ws.Columns(maxCol + 1).Insert

　　　　　　Next

　　　　End If

　　Next

　　

　　Application.ScreenUpdating = True

End Sub

同一値を考慮してCollectionを使いましたが、同一値が無ければもっと簡単に済みます。

シートのSortBy関数


  
    
      Sub VBA100_36_04()

　　Dim ws As Worksheet

　　Dim maxCol As Long

　　Set ws = ActiveSheet

　　maxCol = ws.Range("A1").CurrentRegion.Columns.Count

　　

　　Application.ScreenUpdating = False

　　

　　Dim arySht() As Long, aryKey() As Long

　　ReDim arySht(1 To maxCol, 1 To 2)

　　ReDim aryKey(1 To maxCol, 1 To 1)

　　

　　Dim i As Long, arySort

　　For i = 1 To maxCol

　　　　arySht(i, 1) = getSortKey(ws.Cells(1, i))

　　　　arySht(i, 2) = i

　　　　aryKey(i, 1) = arySht(i, 1)

　　Next

　　arySort = WorksheetFunction.SortBy(arySht, aryKey, 1)

　　

　　For i = UBound(arySort, 1) To LBound(arySort, 1) Step -1

　　　　ws.Columns(arySort(i, 2)).Copy

　　　　ws.Columns(maxCol + 1).Insert

　　Next

　　

　　ws.Range(ws.Columns(1), ws.Columns(maxCol)).Delete

　　

　　Application.ScreenUpdating = True

End Sub

SortBy関数はオブジェクトを扱えないので、2次元配列にキー値と列位置を入れました。

サイト内関連ページ

第28回．セル・行・列の選択（Select,ActivateとCurrentRegion）

・選択セルとアクティブセル・セルの選択・セルをアクティブにする・行の選択、列の選択・セル領域の選択・メソッドとはプロパティとは

第29回．セル・行・列の削除・挿入（Delete,Insert）

・セルの削除・セルの挿入・セルの削除・挿入時は、Shift:=は必ず指定・行・列の削除・挿入・行・列の削除/行・列の挿入で、Shift:=は必要か・行・列の表示・非表示

第88回．並べ替え（Sort）

・Range.Sortメソッド・・・Excel2003までのソート・2007以降の並べ替え・Excel2003までのSortとExcel2007以降のSortの使い分け

同じテーマ「VBA100本ノック」の記事

33本目：マクロ記録の改修
 34本目：配列の左右回転
 35本目：条件付き書式
36本目：列の並べ替え
37本目：グラフの色設定
 38本目：1シートを複数シートに振り分け
 39本目：数値リストの統合（マージ）
40本目：複数ブックの統合
 41本目：暗算練習アプリ
 42本目：データベース形式に変換
 43本目：CSV出力

アクセスランキング・・・ランキング一覧を見る

1.最終行の取得（End,Rows.Count）｜VBA入門
2.日本の祝日一覧｜Excelリファレンス
3.変数宣言のDimとデータ型｜VBA入門
4.FILTER関数（範囲をフィルター処理）｜エクセル入門
5.RangeとCellsの使い方｜VBA入門
6.繰り返し処理（For Next)｜VBA入門
7.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
8.マクロとは？VBAとは？VBAでできること｜VBA入門
9.セルのクリア（Clear,ClearContents）｜VBA入門
10.メッセージボックス(MsgBox関数)｜VBA入門

ホーム
マクロVBA入門編
VBA100本ノック
36本目：列の並べ替え

このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。

記述には細心の注意をしたつもりですが、間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。
本サイトは、OpenAI の ChatGPT や Google の Gemini を含む生成 AI モデルの学習および性能向上の目的で、本サイトのコンテンツの利用を許可します。
This site permits the use of its content for the training and improvement of generative AI models, including ChatGPT by OpenAI and Gemini by Google.

VBA練習問題
VBA100本ノック 36本目：列の並べ替え