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

VBAを100本の練習問題で鍛えます
最終更新日:2021-02-22

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


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


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

VBAテスト用のサンプルデータは、VBA100本ノックの目次ページ からもダウンロードできます。
マクロVBAを初心者向けの基本から上級者向けの高度な内容までサンプルコードを掲載し解説しています。エクセル関数・機能・基本操作の入門解説からマクロVBAまでエクセル全般を網羅しています。


出題

出題ツイートへのリンク

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

マクロ VBA 100本ノック

マクロ VBA 100本ノック


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


頂いた回答

解説

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)
マクロVBAで、セル、行、列を選択するときの記述について説明します。まずは、セルの選択について説明する前に、選択セルとアクティブセルについて、説明する必要があります。選択セルとアクティブセル この状態で、選択セルは、B2~C6の10個のセルです。
第29回.セル・行・列の削除・挿入(Delete,Insert)
単一セルまたは複数セルの削除・挿入と行・列の削除・挿入についてのVBAを解説します。単一セルまたは複数セルを指定しての行全体・列全体に対する削除・挿入と、行・列を指定しての削除・挿入は結果としては同じ事になりますが、VBAの書き方には違いがあり、実際のVBAでは使い分けが必要になる場合があります。
第88回.並べ替え(Sort)
並べ替えは、データ処理の基本中の基本です、乱雑なデータを並べ替えることは、データ処理の第一歩です。マクロVBAで並べ替えを実行するには、シート操作の「並べ替え」の機能を使用することになります。そもそもデータを並べ替えるという事は、そのデータのキーが何かを考えるという事です。




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

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


新着記事NEW ・・・新着記事一覧を見る

PropertyのSetはLetでも良い|VBA技術解説(2021-03-31)
エクセル麻雀ミニゲーム|VBAサンプル集(2021-03-09)
VBA100本ノック 100本目:WEBから100本ノックのリストを取得|VBA練習問題(2021-03-03)
VBA100本ノック 魔球編:2桁の最小公倍数|VBA練習問題(2021-02-02)
Select Caseでの短絡評価(ショートサーキット)の使い方|VBA技術解説(2021-01-03)
VBA100本ノック 迷宮編:巡回セル問題|VBA練習問題(2020-12-31)
VBA100本ノック 魔球編:閉領域の塗り潰し|VBA練習問題(2020-12-16)
VBA100本ノック 魔球編:組み合わせ問題|VBA練習問題(2020-12-02)
将棋とプログラミングについて~そこには型がある~|エクセル雑感(2020-11-22)
VBA100本ノック 1本目:セルのコピー|VBA練習問題(2020-10-19)


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

1.最終行の取得(End,Rows.Count)|VBA入門
2.RangeとCellsの使い方|VBA入門
3.変数宣言のDimとデータ型|VBA入門
4.マクロって何?VBAって何?|VBA入門
5.Excelショートカットキー一覧|Excelリファレンス
6.繰り返し処理(For Next)|VBA入門
7.Range以外の指定方法(Cells,Rows,Columns)|VBA入門
8.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
9.セルに文字を入れるとは(Range,Value)|VBA入門
10.とにかく書いてみよう(Sub,End Sub)|VBA入門




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


記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。



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