念仏寺とフォルクローレトップページに戻ります

エクセルVBA８「並び替える」

モジュールのソースをボタンでコピーできるようにしました。ホームページに載っているソースをコピーしようとしてドラッグしかけて、うまく全体がコピーできなかったことを今まで何度も経験していると、簡単にコピーできるほうがありがたい。そんな思いで一括コピーするボタンをつけてみました。もちろん私はエクセルVBAといっても本で読んだり、他の人のHPを参考にしながら、自分が利用しそうなものをまとめているだけで、自分なりに手を加えている箇所は非常に少ないだろうと思います。

エクセルVBAのマクロの記述モジュールは緑の枠内に記述しています。｢モジュールをコピーする｣のボタンをクリックすると、このモジュール全体を一発でコピーします。それを貼り付けてマクロを実行してみてください。


「エクセルVBA事始め」に戻る

このページの目次


１　行をランダムにシャッフルする(2015,11,21)

２　第1行の列をランダムにシャッフル(2015,11,21)

３　表の列をランダムにシャッフル (2015,11,21)

４　表の列を２つの条件で並び替える (2016,6,5)

５　表の行を２つの条件で並び替える (2016,6,5)

６　表の列を昇順とランダムの２条件で並び替え (2016,6,5)

7　表の行列を入替えてルビも含めて縦書きを横書きに貼り付け　 (2016,6,5)

　



◆◆◆　1　A列の行をランダムにシャッフルする ◆◆◆

行を昇順・降順に並び替えるのはメニューからすぐできるが、ランダムにシャッフルしようとすると、隣の列にでも「=RAND()」を入力して必要な行数分コピーしてから、この列を昇順なり、降順に並び変えるとランダム（順不同）にシャッフルできる。それをマクロでやってみようというのがここのテーマです。

関数式を入れて乱数を取得し、並び替えて、その乱数を削除するという形でマクロを組んでいるサイト「やむえむのExcel VBAメモ」があったので参照させていただきました。これは、A1〜A10にデータがあり、B列に乱数を入力し、順番（昇順）に並ばせ、最後にそのB列の乱数を削除するというものです。


Sub 行をランダムにシャッフル()
' マクロ記録日 : 2015/11/21  ユーザー名 : canchan
'A1:A10にデータがある。B列に乱数を発生させシャッフル。
    Dim i As Integer
    Randomize
    '乱数を入れる
    For i = 1 To 10
        Cells(i, 2) = Rnd()
    Next i
    '乱数で昇順並び替え
    Range("A1:B10").Sort _
        Key1:=Range("B1"), Order1:=xlAscending, _
        Header:=xlNo, _
        OrderCustom:=1, _
        MatchCase:=False, _
        Orientation:=xlTopToBottom, _
        SortMethod:=xlPinYin
    '乱数を削除
    Range("B1:B10").Clear
End Sub
モジュールをコピーする


このページの目次に戻る


◆◆◆　2　第1行の列をランダムにシャッフル　◆◆◆

「１　行をランダムにシャッフルする」はA列の行を入れ替えてシャッフルするものでした。つぎに、A1〜J1に並んでいるデータをランダムにシャッフルしてみましょう。 


Sub 列をランダムにシャッフル()
' マクロ記録日 : 2015/11/21  ユーザー名 : canchan
    Dim i As Integer
    Randomize
    '行2に乱数を入れる。データはA1:J1に１０個
    For i = 1 To 10
        Cells(2, i ) = Rnd()
    Next i
    '乱数で昇順並び替え
    Range("A1:J2").Sort _
        Key1:=Range("A2"), Order1:=xlAscending, _
        Header:=xlGuess, _
        OrderCustom:=1, _
        MatchCase:=False, _
        Orientation:=xlLeftToRight, _
        SortMethod:=xlPinYin
    '乱数を削除
    Range("A2:J2").Clear

End Sub


モジュールをコピーする


このページの目次に戻る


◆◆◆　３　表の列をランダムにシャッフル　◆◆◆

「２　列をランダムにシャッフルする」ではA1〜J1に並んでいる１０個のデータをランダムにシャッフルしました。次に、データの数が縦横ともに変わっても表内の列をシャッフルさせるにはどうしたらよいかやってみましょう。

表の周りには1マス以上の空白セルを設定してください。


Sub 表の列をランダムにシャッフル()
' マクロ記録日 : 2015/11/21  ユーザー名 : canchan
    Dim C As Range      '表の範囲
    Dim Cr As Long    '基準セルの行位置
    Dim Cc As Long    '基準セルの列位置
    Dim rCnt As Long    '行数
    Dim cCnt As Long    '列数
    Dim i As Integer
Set C = Application.InputBox(prompt:="表の左上セルをクリックしてください", Type:=8)
'typeは　０：数式，１：数値，２：文字列，４：論理値（true/false) ,８：セル参照(Rangeオブジェクト），１６：Excelのエラー値(#N/Aなど），６４：数値配
C.Select
    Cr = Selection.Row
    Cc = Selection.Column
'c を含む列の最下行までの行数を数える
    rCnt = C.CurrentRegion.SpecialCells(xlCellTypeVisible).Rows.Count
'c を含む行の最右列までの列数を数える
    cCnt = C.CurrentRegion.SpecialCells(xlCellTypeVisible).Columns.Count
'数式で空白になっているセルの数まで含めている

    Randomize
    
'表の1行下に乱数を入れる。
    For i = 1 To cCnt
        Cells(Cr + rCnt, Cc - 1 + i) = Rnd()
    Next i
    '乱数で昇順並び替え
    Range(Cells(Cr, Cc), Cells(Cr + rCnt, Cc + cCnt - 1)).Sort _
        Key1:=Cells(Cr + rCnt, Cc + cCnt - 1), Order1:=xlAscending, _
        Header:=xlGuess, _
        OrderCustom:=1, _
        MatchCase:=False, _
        Orientation:=xlLeftToRight, _
        SortMethod:=xlPinYin
    '乱数を削除
    Range(Cells(Cr + rCnt, Cc), Cells(Cr + rCnt, Cc + cCnt - 1)).Clear

End Sub


モジュールをコピーする


このページの目次に戻る


◆◆◆　４　表の列を２つの条件で並び替える　◆◆◆

列を並び替えるのに、２つの行を参照して並び変えることを考えてみます。

A3を含む表としてマクロを作成しているので、A２の行は空白にします。表の周りには1マス以上の空白セルを設定してください。上の表の中で、A5の行を第１条件として「1,2・・・」と昇順に並び替え、A4の行を「おえういあ」のように降順に並び替えるとします。

下記のマクロを実行すると

となります。


Sub 並び替え2条件()
Range("A3").Sort _
    Key1:=Range("A5"), Order1:=xlAscending, _
    Key2:=Range("A4"), Order2:=xlDescending, _
    Header:=xlNo, _
    Orientation:=xlLeftToRight
   
End Sub


モジュールをコピーする


このページの目次に戻る


◆◆◆　５　表の行を２つの条件で並び替える　◆◆◆

行列を並び替えるのに、２つの列を参照して並び変えることを考えてみます。

A3を含む表としてマクロを作成しているので、A２の行は空白にします。表の周りには1マス以上の空白セルを設定してください。上の表の中で、A5の行を第１条件として「1,2・・・」と昇順に並び替え、A4の行を「おえういあ」のように降順に並び替えるとします。

下記のマクロを実行すると

となります。


Sub 行で並び替え2条件()
Range("A3").Sort _
    Key1:=Range("B3"), Order1:=xlAscending, _
    Key2:=Range("C3"), Order2:=xlDescending, _
    Header:=xlNo, _
    Orientation:=xlSortColumns
   
End Sub


モジュールをコピーする


このページの目次に戻る


◆◆◆　６　表の列を昇順とランダムの２条件で並び替える　◆◆◆

行列を並び替えるのに、２つの列を参照して並び変えることを考えてみます。条件の１つは、昇順に並べる。条件の２はランダムに並べる。◆３◆のところでランダムに並べ替えることをやっていましたが、俳句教室などで１５人の人が一人が２句を持ち寄りそれをランダムに並び替えてみたところ、同じ人の句が並んでしまうという状態になっていました。入力時点で投句票から並べて入力していくのでそのような状況になってしまうようです。連続させないために５回ほどマクロを実行して同じ人の句が離れるようにさせていました。今回は、一つの行を同一人物を数える欄を設けたとしてこのマクロを考えてみました。

A3を含む表としてマクロを作成しているので、A２の行は空白にします。表の周りには1マス以上の空白セルを設定してください。上の表の中で、第１の条件としてA5の行を「1,2・・・」と昇順に並び替え、第２条件としてA4の行をランダムに並び替えるというものです。こうすることによって同じ人の句が並ぶのは１と２の境界部分だけとなり連続する確率もかなり減るものと考えられます。

下記のマクロを実行すると、１回目は

２回目のマクロ実行で

３回目のマクロ実行で

となります。A5行は１の組と２の組とに分かれたままでA3行とA4行とが変わっていくようになります。個人の複数の句をランダムに並び替えるには効率が良さそうです。


Sub 条件は昇順とランダムで列並び替え()
'ユーザー名 : canchan
'    Dim C As Range      '表の範囲 左上をA3
    Dim Cr As Long    '基準セルの行位置
    Dim Cc As Long    '基準セルの列位置
    Dim rCnt As Long    '行数
    Dim cCnt As Long    '列数
    Dim i As Integer
'A3を基準とするから
    Cr = 3
    Cc = 1

'c を含む列の最下行までの行数を数える
    rCnt = Range("A3").CurrentRegion.Rows.Count
'c を含む行の最右列までの列数を数える
    cCnt = Range("A3").CurrentRegion.Columns.Count
'数式で空白になっているセルの数まで含めている
    Randomize
'表の1行下に乱数を入れる。
    For i = 1 To cCnt
        Cells(Cr + rCnt, Cc - 1 + i) = Rnd()
    Next i
    '乱数で昇順並び替え
    Range(Cells(Cr, Cc), Cells(Cr + rCnt, Cc + cCnt - 1)).Sort _
        Key1:=Range("A5"), Order1:=xlAscending, _
        Key2:=Cells(Cr + rCnt, Cc + cCnt - 1), Order1:=xlAscending, _
        Header:=xlNo, _
        OrderCustom:=1, _
        MatchCase:=False, _
        Orientation:=xlLeftToRight, _
        SortMethod:=xlPinYin
    '乱数を削除
    Range(Cells(Cr + rCnt, Cc), Cells(Cr + rCnt, Cc + cCnt - 1)).Clear

End Sub


モジュールをコピーする


このページの目次に戻る


◆◆◆　7　表の行列を入替えてルビも含めて縦書きを横書きに貼り付け　◆◆◆

エクセルの縦書き俳句一覧表をワードにいきなり貼り付けようとすると、俳句の行が先に書き出され、作者の欄はその後にまとめて表示される。ワードで縦書きの表にするために試行錯誤。思いついたのは、まず縦書き表示の表を別のシート、ここではSheed3のA2の位置から貼り付けるという作業を行った。その後にその表を選択してワードに貼り付け、表を解除するという作業をしました。行列を入替え、俳句教室の中で氏名欄に丸をつける必要があって付けていたのでそれを除き行列を入替え貼り付けるというマクロを考えてみました。

下記のマクロを実行すると、１回目は


Sub 選択条件書式○除去行列入れ替え()
    '条件付き書式をまず削除する
    Range("A12:AN13").Select　　　　	'ここでは俳句の一覧がA12からAN13まであるとしています。
    Cells.FormatConditions.Delete       ' 全ての条件付き書式を削除
    Cells.Replace What:="○", Replacement:="", LookAt:=xlPart, SearchOrder:= _
        xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False　　　'○印を除去
    Selection.Copy
    Sheets("Sheet3").Select '貼り付けるシート
    Range("A1").Select      '貼り付けを始めるセル
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
       'http://excel-ubara.com/excelvba2/EXCELVBA014.html 参照
        'Transpose:=True は行列の入れ替え　SkipBlanks:=False　は空白セルも対象にしている
        'Paste:=xlPasteAll：すべて(書式も含む)を貼り付けます。ルビもつく
        'xlPasteAllMergingConditionalFormats：すべてを貼り付け、条件付き書式をマージ（併合）します
        'xlPasteAllExceptBorders：輪郭以外のすべてを貼り付けます。
        'xlPasteValues：値を貼り付けます。条件付き書式も貼り付く。
        'xlPasteValuesAndNumberFormats：値と数値の書式を貼り付けます。
        'xlPasteFormats：コピーしたソースの形式???を貼り付けます。
        'FormatConditions.Delete ' 全ての条件付き書式を削除 https://www.tipsfound.com/vba/07020
    Application.CutCopyMode = False
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlTop
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = True
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Columns("A:A").EntireColumn.AutoFit
    Columns("B:B").EntireColumn.AutoFit
    Rows("1:1").EntireRow.AutoFit
    Cells.Select
    Cells.EntireRow.AutoFit
    Cells.EntireColumn.AutoFit
    Range("B5").Select
    Cells.Replace What:="○", Replacement:="", LookAt:=xlPart, SearchOrder:= _
        xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Columns("A:B").Select
End Sub


モジュールをコピーする


このページの目次に戻る




このページの目次に戻る




「エクセルVBA事始め」に戻る