配列 Sortメソッド配列変数並替(文字列可・高速・2次元編)
※より実装に近く表示させる為、コードの改行を避けています。スマホ等で閲覧される際は向きを変えてご覧ください。
※実装するバージョンによってはバージョンアップの仕様により動作しないコードもあります。実装には動作確認の上ご使用下さい。
Sub SortMethodArrayVariable2(ByRef strDataNew() As String, ByVal strDataOld As Variant) '**************************************************** 'Sortメソッド配列変数並替(文字列可・高速・2次元編) '**************************************************** 'エクセルのRangeオブジェクト使用の為65536個を超えると不可。 'ここでは[Callステートメント]による呼び出しで関数化してます。 '既存シートデータに影響が無い様、新シートを使用してます。 '新シートは使用後削除されます。 'より高速にするにはシートを予め用意しておく事です。 'ByVal strDataOld で受け取った配列を 'ByRef strDataNew() で返してます。 Dim NewSheet As Worksheet Dim ArrayMin(1) As Long Dim ArrayMax(1) As Long Dim i As Long, j As Long Dim strDataOldDummy() As String 'Rangeオブジェクト用配列変数 Dim rngDummy As Range '画面更新しない Application.ScreenUpdating = False '新シート追加及びセット Set NewSheet = ThisWorkbook.Worksheets.Add ArrayMin(0) = LBound(strDataOld, 1) '受け取った配列変数最小値 ArrayMax(0) = UBound(strDataOld, 1) '受け取った配列変数最大値 ArrayMin(1) = LBound(strDataOld, 2) '受け取った配列変数最小値 ArrayMax(1) = UBound(strDataOld, 2) '受け取った配列変数最大値 '①受け取った配列変数をRangeオブジェクト用に配列変数を定義 ReDim strDataOldDummy((ArrayMin(0) + 1) To (ArrayMax(0) + 1), _ (ArrayMin(1) + 1) To (ArrayMax(1) + 1)) '②返す配列変数の格納数を定義 ReDim strDataNew(ArrayMin(0) To ArrayMax(0), ArrayMin(1) To ArrayMax(1)) '受け取った配列変数①をRangeオブジェクト用配列変数にコピー For i = ArrayMin(0) To ArrayMax(0) For j = ArrayMin(1) To ArrayMax(1) strDataOldDummy(i + 1, j + 1) = strDataOld(i, j) Next j Next i With NewSheet '③Rangeオブジェクトをセット Set rngDummy = .Range(.Cells(ArrayMin(0) + 1, 1), .Cells(ArrayMax(0) + 1, 2)) 'セットしたRangeオブジェクト③にRangeオブジェクト用配列変数①をコピー rngDummy = strDataOldDummy '③RangeオブジェクトSortメソッド(降順) rngDummy.Sort Key1:=.Cells(1, 2), Order1:=xlDescending, Key2:=.Cells(1, 1), Order2:=xlDescending '返す配列変数②に格納 For i = ArrayMin(0) + 1 To ArrayMax(0) + 1 For j = ArrayMin(1) + 1 To ArrayMax(1) + 1 strDataNew(i - 1, j - 1) = rngDummy(i, j) Next j Next i '③セット解除 Set rngDummy = Nothing End With 'マクロの実行中に特定の警告やメッセージを表示しない Application.DisplayAlerts = False NewSheet.Delete '追加した新シート削除 'マクロの実行中に特定の警告やメッセージを表示する Application.DisplayAlerts = True Set NewSheet = Nothing 'セット解除 Application.ScreenUpdating = True '画面更新する '************************** '重要引数群 '************************** 'Key1 並べ替えの最初に優先されるキーとなるフィールド｡ 'Order1 下記-Order-参照｡ 'Key2 並べ替えの 2 番目に優先されるキーとなるフィールド。 'Order2 下記-Order-参照｡ 'Key3 並べ替えの 3 番目に優先されるキーとなるフィールド。 'Order3 下記-Order-参照｡ '1以外は多次元時(3次元まで)に使用。 '-Order- '昇順に並べ替えるには、xlAscending を指定します(既定) '降順に並べ替えるには、xlDescending を指定します｡ 'Header '最初の行がタイトル行であるかどうかを指定。 'xlGuess-(自動判別)、xlNo-(タイトルなし(既定))、xlYes-(最初の行がタイトル行) 'MatchCase '大文字と小文字を区別して並べ替えるには、True を指定。 '大文字と小文字を区別しないで並べ替えるには、False を指定。 End Sub Private Sub test() Dim strFile(5, 1) As String, str As String strFile(0, 0) = "apple" strFile(1, 0) = "apple" strFile(2, 0) = "apple" strFile(3, 0) = "windows" strFile(4, 0) = "windows" strFile(5, 0) = "windows" strFile(0, 1) = "HD-x" strFile(1, 1) = "HD-Y" strFile(2, 1) = "HD-z" strFile(3, 1) = "HD-A" strFile(4, 1) = "HD-b" strFile(5, 1) = "HD-c" Dim strDataNew() As String Call SortMethodArrayVariable2(strDataNew, strFile) str = "(0, 0)：(0, 1)" & vbTab & strDataNew(0, 0) & " | " _ & strDataNew(0, 1) & vbCr str = str & "(1, 0)：(1, 1)" & vbTab & strDataNew(1, 0) & " | " _ & strDataNew(1, 1) & vbCr str = str & "(2, 0)：(2, 1)" & vbTab & strDataNew(2, 0) & " | " _ & strDataNew(2, 1) & vbCr str = str & "(3, 0)：(3, 1)" & vbTab & strDataNew(3, 0) & " | " _ & strDataNew(3, 1) & vbCr str = str & "(4, 0)：(4, 1)" & vbTab & strDataNew(4, 0) & " | " _ & strDataNew(4, 1) & vbCr str = str & "(5, 0)：(5, 1)" & vbTab & strDataNew(5, 0) & " | " _ & strDataNew(5, 1) & vbCr str = str & "合計数：" & vbTab & UBound(strDataNew, 1) + 1 & vbCr MsgBox str End Sub |