Uncletel's パソコン備忘録

　下記マクロプログラムは、Windows Excel2000で作成していますが、Excel2007でも動作することを確認しています。
おそらく、Excel2010（※動作未確認）でも動作すると思われます。
Macの場合、Excel2008では、動作しません、そもそもマクロ機能がない。Excel2011では、マクロ機能が復活しているようなので、
動作すると思われます。（※動作未確認）
　並べ替えは、Excelの操作で、十分な場合が多いのですが、マクロで並べ替えが必要な時は、参考にしてください。
　また、並べ替え以外でも、例えば前０の数字列の作成の仕方など、ありますので役立ててください。

マクロプログラム動作説明：
　各ステートメントに説明書きがありますので参考にしてください。
　大まかな流れは、
　　１．MkRandサブ関数で、ソート用のデータ作成
　　２．CreateKeyサブ関数で、ソート用のキーを作成
　　３．ReceptSortサブ関数で、ソートを実行

下記マクロプログラムをコピーして、Excel2000/2003の場合には、”ツール”の”マクロ”の”Visual Basic Editor”を選択して開き、
ペーストして、実行です。
Excel2007以降では、メニューに”開発”を追加して、"開発"→”Visual Basic”を選択して開き、ペーストして、実行です。

' main pro

Option Base 1

Option Explicit
    
    Const TARGETSHEET As String = "Sheet1"
    Const TARGETCOLUM As String = "A1"
    Const KEYCOLUMN   As String = "B1"
    
    Dim MaxRows   As Integer
    Dim MaxValue   As Integer
    Dim StartCell As Integer
    Dim cnt, ct   As Integer
    Dim Result    As Range
    
Sub main()
    Worksheets(TARGETSHEET).Activate
    
    MaxRows = 500  'データ数（レコード数）を指定（サンプルデータ作成に時間がかかるので、500が限度）
    MaxValue = 1000
            
    Application.DisplayStatusBar = True                             'ステータスバーを表示する
    MkRand
    Application.StatusBar = False                                   'ステータスバーを開放する
    Application.DisplayStatusBar = False                            'ステータスバーを非表示にする
    
    MsgBox "ソート実行！！"
    ReceptSort

End Sub

'------------------------------------------------------------------------------------------------------
'擬似的にランダムなデータ（重複なし）を作成し、Ｂ列へ格納。
'------------------------------------------------------------------------------------------------------
Sub MkRand()
    
    StartCell = 1
    
    Randomize
    For cnt = 1 To MaxRows
        Cells(cnt + StartCell - 1, 1) = cnt
        Cells(cnt + StartCell - 1, 2) = Int((MaxValue) * Rnd + 1)
        If cnt <> 1 Then
            For ct = 1 To cnt - 1
                If Cells(ct + StartCell - 1, 2) = Cells(cnt + StartCell - 1, 2) Then
                    Cells(cnt + StartCell - 1, 2) = Int((MaxValue) * Rnd + 1)
                    ct = 0
                End If
            Next
        End If
        Application.StatusBar = "データを作成中・・" & cnt & " (" & MaxRows & " 中)"
    Next
    For cnt = 1 To MaxRows
        CreateKey
    Next
End Sub

'------------------------------------------------------------------------------------------------------
'指定列(例：Ｂ4列)のデータを昇順に並べ替える。（行単位で入れ替え：ソート）
'------------------------------------------------------------------------------------------------------
Sub ReceptSort()
    Range(TARGETCOLUM).Sort Key1:=Range(KEYCOLUMN), Order1:=xlAscending
End Sub

'------------------------------------------------------------------------------------------------------
'ソート用キーを作成する。
'------------------------------------------------------------------------------------------------------
Sub CreateKey()

    Dim Request_mark   As String  'ソート用キー

    Request_mark = Right(Application.WorksheetFunction.Rept("0", 7) & Cells(cnt + StartCell - 1, 2), 7)
    
    Cells(cnt + StartCell - 1, 2).NumberFormatLocal = "@"
    Cells(cnt + StartCell - 1, 2) = "01-" & Request_mark
End Sub