VBA：列データをバラバラに並べ替える

VBA：列データをバラバラに並べ替える プログラム
2015.07.03

エクセルでもプログラムが出来るということで、VBA(=Visual Basic for Applications)を使ってマクロを作った。
「列Aに入力されたデータを列Cにバラバラに並べ替えて表示する」というマクロだ。

ダウンロードExcel97形式

プログラムの流れは以下の通り。

１）列Aの2行目以降に入力されたデータを最後のセルまで選択（データは途中で途切れていないことが前提）

２）１）のデータを列Cにコピー

３）コピーしたデータをデータ件数×10回くらいランダムに入れ替える

１）で、列のデータ数が不確定の場合に使える命令が

Selection.End(xlDown).Select

だ。
列のデータが途中で途切れていないことが前提だが、列Aの1行目から最後のデータが入っている列番号を取得するには、

    ' データの先頭行から終了行までをチェック
    Cells(1, 1).Select
    Selection.End(xlDown).Select
    dataEnd = Selection.row

の様に使う。（上記、4行目のdataEndは変数）

３）の並べ替えは、データが入っている行番号に対応した乱数を2つ発生させ、データ退避用のセル（列Cの使っていないセル）を介して入れ替えるようにしている。

    ' コピーしたデータをバラバラにする
    Randomize
    For i = 1 To dataCount * 10    ' データ数×10回くらい入れ替えればバラバラになるかなぁ、という感じ
        r1 = Int(Rnd * dataCount + START_ROW)
        r2 = Int(Rnd * dataCount + START_ROW)
        
        Cells(dataEnd + 2, COPY_COL).Value = Cells(r1, COPY_COL).Value
        Cells(r1, COPY_COL).Value = Cells(r2, COPY_COL).Value
        Cells(r2, COPY_COL).Value = Cells(dataEnd + 2, COPY_COL).Value
    Next i

エクセルのマクロ記録ボタンを押してマクロが作成できるが、セルの選択はRangeで記述される。プログラムで使うには行列を数値で指定できるCellsの方が使いやすい。

例えばA列の3行目ならRangeだと

Range("A3").Select

などと書くが、

Cellsだと

Cells(3,1).Select

となる。（3行1列という意味。すなわちA列の3行目）

作ったマクロに話を戻す。
「バラバラにする」ボタンを押すと、

barabara2

データ数を取得して、列Cにコピーします。

その後、セルのデータをバラバラにしていきます。
実行すると分かりますが、プログラム内部で変数を使わずにセルコピーで並べ替えているので、コンピュータが頑張っているところを目で追えます！

barabara3

見事バラバラになりました。

エクセルがインストールされているパソコンは多いですし、プログラムの勉強には十分だと思います。
最初はマクロの記録ボタンでコンピュータが生成したプログラムを見て、編集できそうなところは自分なりに変更してみて改良していくと少しずつ作れるようになっていきます。
出来ればマニュアルもインストールしておいて分からない命令をVBE(=Visual Basic for Editor)の画面で選択してからF1キーを一発

vbahelp

のようなマニュアルを開いて、使い方を詳しく調べることが出来ます。（難しそうですか？そうですか。わたしは結構マニュアル読むのが好きです。変なんで）

使ったマクロは以下の通り

Sub barabara()
' VBA: シートの列データをコピーしてバラバラに並べるマクロ
'
    Dim i As Integer
    Dim dataEnd As Integer      ' データの最終行
    Dim dataCount As Integer    ' データ数
    Dim r1, r2 As Integer       ' 入れ替え用に使用（考え方／r1の行とr2の行のデータを入れ替える）
    Dim waitTime As Variant     ' 待ち時間
    
    Const DATA_COL = 1          ' 元データの列（A列）
    Const START_ROW = 2         ' 元データの先頭行（2行目）
    Const COPY_COL = 3          ' コピー先の列（C列）
    
    ' コピー先列を消しておく
    Columns(COPY_COL).Select
    Selection.ClearContents

    
    ' データの先頭行から終了行までをチェック
    Cells(START_ROW, DATA_COL).Select
    
    ' データが無い場合の対処
    If Selection.Value = "" Then
        MsgBox ("データがないです")
        Exit Sub
    End If
    
    Selection.End(xlDown).Select
    On Error GoTo ONEDATA       ' データが1件の場合の対処
    
    dataEnd = Selection.row
    
    
    ' 元データ（A列）をC列にコピー
    Range(Cells(START_ROW, DATA_COL), Cells(dataEnd, DATA_COL)).Select
    Selection.Copy
    Cells(START_ROW, COPY_COL).Select
    ActiveSheet.Paste
    
    ' データ数を取得
    dataCount = dataEnd - START_ROW + 1
    MsgBox ("データ数 = " & dataCount)
    
    ' 3秒待つ（コンピュータが考えているように見せるためにいれた処理です）
    waitTime = Now + TimeValue("0:00:03")
    Application.Wait waitTime
    
    
    ' コピーしたデータをバラバラにする
    Randomize
    For i = 1 To dataCount * 10    ' データ数×10回くらい入れ替えればバラバラになるかなぁ、という感じ
        r1 = Int(Rnd * dataCount + START_ROW)
        r2 = Int(Rnd * dataCount + START_ROW)
        
        Cells(dataEnd + 2, COPY_COL).Value = Cells(r1, COPY_COL).Value
        Cells(r1, COPY_COL).Value = Cells(r2, COPY_COL).Value
        Cells(r2, COPY_COL).Value = Cells(dataEnd + 2, COPY_COL).Value
    Next i
    
    ' 作業に使ったセルデータを消しておく
    Cells(dataEnd + 2, COPY_COL).Value = ""
    Cells(dataEnd + 1, DATA_COL).Select
    Exit Sub

ONEDATA:
    MsgBox ("データが1件だと並べ替えできないよ")
    Selection.End(xlUp).Select
    
End Sub

コメント

タイトルとURLをコピーしました