VBA100本ノック 36本目:列の並べ替え
こちらで公開されている、100本ノックに挑戦。
www.excel-ubara.com
素晴らしい教材を公開いただき、ありがとうございます。
上記リンク先から、問題文を転載。
( )内の数字で並べ替えるわけだが、( )以外の表記に一貫性がない。
従って、単純な並び替えでは上手くいかなそうだ。
ということで今回は、正規表現を用いて一旦数字だけを抽出し、この情報を
元に並び替えることとした。
Sub VBA_100Knock_36() ' ( )内の数字を正規表現で抽出。 Dim myReg As VBScript_RegExp_55.RegExp Set myReg = New VBScript_RegExp_55.RegExp myReg.Pattern = "\((\d+)\)" Dim MC As VBScript_RegExp_55.MatchCollection Dim arr As Variant arr = Range("A1").CurrentRegion ' ラベル行の()内の数字を、ラベル文字先頭に表示。 ' 桁数を揃えるため、書式「K000」にしている。 ' Kは、Sort KeyのK。 Dim i As Long For i = 1 To UBound(arr, 2) If myReg.Test(arr(1, i)) Then Set MC = myReg.Execute(arr(1, i)) arr(1, i) = Format(MC(0).SubMatches(0), "K000") & _ "_" & arr(1, i) End If Next ' 元のデータを一旦クリアし、縦横変換して貼り付け。 Range("A1").CurrentRegion.ClearContents Range("A1").Resize(UBound(arr, 2), UBound(arr, 1)) = _ WorksheetFunction.Transpose(arr) ' 一列目でソート。 Dim Sh As Worksheet: Set Sh = ActiveSheet Sh.Sort.SortFields.Clear Sh.Sort.SortFields.Add Key:=Range("A1") With Sh.Sort .SetRange Range("A1").CurrentRegion .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With ' 配列に格納して、もう一度縦横変換。 arr = Sh.Range("A1").CurrentRegion arr = WorksheetFunction.Transpose(arr) ' ラベルに追加した、ソート用の「K000」を除去。 Dim Temp As Variant For i = 1 To UBound(arr, 2) Temp = Split(arr(1, i), "_") If UBound(Temp) <> 0 Then arr(1, i) = Temp(1) End If Next ' 並べ替えに使用したデータをクリアして、並べ替え後の配列を貼り付け。 Range("A1").CurrentRegion.ClearContents Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr End Sub
↓ 結果がこちら。
※冒頭リンク先の解答例および解説も、ぜひご一読ください。
参考まで。