【VBA】表をソートする(Range.Sortメソッドを使用)

0

    <機能>

    Range.Sortメソッドを使用して指定列で表をソートします

    (1)アクティブシートにテスト用の表「日本百名山」を作成

    (2)B列の「標高」で表をソートします

     

    <動作検証&開発環境>
    Microsoft Office 2016

     

    <使い方>

    適当なところにソースを張り付けてください

    VBAで表をソートする() を実行するとソート処理を開始します

     

    <実行イメージ>

    ソート前とソート後のイメージです

    Sort,ソート,表のソート,Range.Sort,

     

    '********************************************

    'VBAでリスト(表)をソートする

    '(1)アクティブシートにテスト用の表(日本百名山)を作成

    '(2)標高の降順でソート(高い順でソート)

    '********************************************

    Sub VBAで表をソートする()

       

        '//テストデータ「日本百名山」表を作成

        SetTestData

           

        '//標高でソートする

        '//項目行を除くため2行目移行をソートする

        '//Office Dev Centerはこちら

        '//Key1 : 最初の並べ替えフィールド(B列の標高で並べ替え)

        '//order1: Key1で指定した値の並べ替え順序(昇順:xlAscending 降順:xlDescending)

        '//Header: 最初の行にヘッダ情報が含まれているか(ヘッダを判断:xlGuess 含まれない(規定値):xlNo 含まれる:xlYes)

        Columns("A:B").Sort _

            Key1:=Range("B2"), _

            order1:=xlDescending, _

            Header:=xlYes

        Range("A1").Select

    End Sub

     

    '********************************************

    'アクティブシートに「日本百名山」表を作成する

    '********************************************

    Sub SetTestData()

        Dim ar As Variant

        ar = Array("百名山,標高(m)", "利尻岳,1721", "羅臼岳,1660", "斜里岳,1545", "阿寒岳,1499", "大雪山,2290", _

        "トムラウシ,2141", "十勝岳,2077", "幌尻岳,2052", "後方羊蹄山,1898", "岩木山,1625", _

        "八甲田山,1584", "八幡平,1613", "岩手山,2038", "早池峰山,1917", "鳥海山,2236", _

        "月山,1984", "朝日岳,1870", "蔵王山,1841", "飯豊山,2128", "吾妻山,2035", _

        "安達太良山,1709", "磐梯山,1819", "会津駒ヶ岳,2133", "那須岳,1917", "燧ヶ岳,2356", _

        "至仏山,2228", "武尊山,2158", "男体山,2484", "奥白根山,2578", "皇海山,2144", _

        "赤城山,1828", "筑波山,877", "両神山,1723", "雲取山,2017", "甲武信岳,2475", _

        "金峰山,2599", "瑞牆山,2230", "大菩薩嶺,2057", "丹沢山,1673", "富士山,3776", _

        "天城山,1406", "谷川岳,1977", "草津白根山,2578", "四阿山,2354", "浅間山,2568", _

        "越後駒ヶ岳,2003", "平ヶ岳,2141", "巻機山,1967", "雨飾山,1963", "苗場山,2145", _

        "妙高山,2454", "火打山,2462", "高妻山,2353", "白馬岳,2932", "五竜岳,2814", _

        "鹿島槍ヶ岳,2889", "剱岳,2998", "立山,3015", "薬師岳,2926", "黒部五郎岳,2840", _

        "水晶岳,2986", "鷲羽岳,2924", "槍ヶ岳,3180", "穂高岳,3190", "常念岳,2857", _

        "笠ヶ岳,2897", "焼岳,2455", "乗鞍岳,3026", "御嶽山,3067", "美ヶ原,2034", _

        "霧ヶ峰,1925", "蓼科山,2530", "八ヶ岳,2899", "木曽駒ヶ岳,2956", "空木岳,2864", _

        "恵那山,2191", "甲斐駒ヶ岳,2967", "仙丈ヶ岳,3033", "鳳凰山,2840", "北岳,3192", _

        "間ノ岳,3189", "塩見岳,3052", "悪沢岳,3141", "赤石岳,3120", "聖岳,3013", _

        "光岳,2591", "白山,2702", "荒島岳,1523", "伊吹山,1377", "大台ヶ原山,1695", _

        "大峰山,1915", "大山,1729", "剣山,1955", "石鎚山,1982", "九重山,1791", _

        "祖母山,1756", "阿蘇山,1592", "霧島山,1700", "開聞岳,924", "宮之浦岳,1936")

        

        ThisWorkbook.Activate

        Cells.Select

        Selection.Clear

        Selection.ColumnWidth = 15

        Selection.RowHeight = 30

        Selection.Font.Name = "MS ゴシック"

        Selection.Font.Size = 10

        '//折り返して全体を表示する

        Selection.WrapText = True

        Range("A1").Select

        

        '//データをシートに展開

        Dim i As Integer, j As Integer

        Dim wkbuf As Variant

        

        For i = 0 To UBound(ar)

            wkbuf = Split(ar(i), ",")

            '不正なデータであれば次レコードへ

            If UBound(wkbuf) <> 1 Then GoTo nextrec

            'データを表示

            For j = 0 To UBound(wkbuf)

                Cells(i + 1, j + 1) = wkbuf(j)

            Next j

        

    nextrec:

        Next i

        

        '//罫線を引く

        With Range("A1:B" & CStr(UBound(ar) + 1)).Borders

            .LineStyle = xlContinuous

            .Weight = xlMedium

        End With

        '//項目行の背景色をセット

        With Range("A1:B1")

            .Interior.Color = RGB(0, 255, 130)

            .HorizontalAlignment = xlHAlignCenter

            .VerticalAlignment = xlVAlignCenter

        End With

    End Sub

     

    よろしければポチッと押してください


    プログラマー ブログランキングへ



    calendar

    S M T W T F S
         12
    3456789
    10111213141516
    17181920212223
    24252627282930
    31      
    << December 2017 >>

    profile

    others

    mobile

    qrcode