配列 Sortメソッド配列変数並替(文字列可・高速・2次元編)

VB&VBA
FROG ふろっぐ
 
  • オプション

    本文印刷

    お気に入りに追加

  • 検索

    Googlewwwjp-ia
     

    Googlewwwjp-ia
     
  • 情報

  • 関連

[VB&VBA][配列 Sortメソッド配列変数並替(文字列可・高速・2次元編)]
Option Explicit


Sub SortMethodArrayVariable2(ByRef strDataNew() As StringByVal 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))
'A返す配列変数の格納数を定義
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

        'BRangeオブジェクトをセット
        Set rngDummy = .Range(.Cells(ArrayMin(0) + 1, 1), .Cells(ArrayMax(0) + 1, 2))
        'セットしたRangeオブジェクトBにRangeオブジェクト用配列変数@をコピー
        rngDummy = strDataOldDummy
        'BRangeオブジェクトSortメソッド(降順)
        rngDummy.Sort Key1:=.Cells(1, 2), Order1:=xlDescending, Key2:=.Cells(1, 1), Order2:=xlDescending
        '返す配列変数Aに格納
        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
        'Bセット解除
        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






Production Japan Import Application. Since 1998