Excel(エクセル)2007のVBAで

A列(1列)において、データを「昇順」に並べ替えるコード(ソース)と「降順」に並べ替えるコードをそれぞれ教えてほしいです。

※昇順=文字数が少ないものから多いもの順
※降順=文字数が多いものから少ないもの順



●昇順のコマンドボタン(CommandButton1_Click)で、
A1~A列の(データが存在する)最終行までを対象にして昇順に並べ替えたいです。
※A1~A列の最終行の間に、空白のセル(データの存在しないセル)がないものとします。

●降順のコマンドボタン(CommandButton2_Click)で、
A1~A列の(データが存在する)最終行までを対象にして降順に並べ替えたいです。
※A1~A列の最終行の間に、空白のセル(データの存在しないセル)がないものとします。


【補足】
文字数の数え方は、
「全角1文字」を1文字、「半角1文字」を0.5文字として数えたいです。

(例)
アイウエオ ⇒ 5文字
アイウエオ ⇒ 2.5文字

12345 ⇒ 2.5文字
12345 ⇒ 5文字



上記の条件でVBAコードの分かる方、書ける方がいましたら
どうかよろしくおねがいします。

回答の条件
  • 1人3回まで
  • 13歳以上
  • 登録:2011/04/14 14:11:58
  • 終了:2011/04/14 20:32:40

ベストアンサー

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692011/04/14 14:47:10

ポイント100pt

これはワークシートだけでもできます。

1 作業列にB列を挿入

2 数式に=LENB(A1)を最終行までいれて文字数をカウント

3 B列でソート

4 B列を削除


これをVBAでやるコードなら

Sub Macro1()
    Dim i As Long
    Dim lastRow As Long
    
    Columns("B:B").Insert shift:=xlToRight
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    For i = 1 To lastRow
        Cells(i, "B").Value = LenB(StrConv(Cells(i, "A").Value, vbFromUnicode))
    Next i
    
    Range("A:B").Sort key1:=Range("B1"), order1:=xlDescending  'xlAscending
    
    Columns("B:B").Delete
End Sub

VBAの場合は、unicodeなんでLenBで全部2byteになるから、Shift JISに変換してます。


Sort関数の説明

http://excelvba.pc-users.net/fol7/7_4.html

id:egaosaiko

SALINGERさん

お答えいただきありがとうございます。

2パターンの方法、大変ためになります。

特にVBAコードは重宝すると思います。

エラーもなく完璧に動きました。

ありがたいですね!

2011/04/14 19:26:48

その他の回答(1件)

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692011/04/14 14:47:10ここでベストアンサー

ポイント100pt

これはワークシートだけでもできます。

1 作業列にB列を挿入

2 数式に=LENB(A1)を最終行までいれて文字数をカウント

3 B列でソート

4 B列を削除


これをVBAでやるコードなら

Sub Macro1()
    Dim i As Long
    Dim lastRow As Long
    
    Columns("B:B").Insert shift:=xlToRight
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    For i = 1 To lastRow
        Cells(i, "B").Value = LenB(StrConv(Cells(i, "A").Value, vbFromUnicode))
    Next i
    
    Range("A:B").Sort key1:=Range("B1"), order1:=xlDescending  'xlAscending
    
    Columns("B:B").Delete
End Sub

VBAの場合は、unicodeなんでLenBで全部2byteになるから、Shift JISに変換してます。


Sort関数の説明

http://excelvba.pc-users.net/fol7/7_4.html

id:egaosaiko

SALINGERさん

お答えいただきありがとうございます。

2パターンの方法、大変ためになります。

特にVBAコードは重宝すると思います。

エラーもなく完璧に動きました。

ありがたいですね!

2011/04/14 19:26:48
id:Mook No.2

Mook回答回数1312ベストアンサー獲得回数3912011/04/14 18:20:27

ポイント200pt

こちらは他の回答も出ており、そちらで解決すると思いますので手抜きですが、一応質問への回答です。


'// 文字数昇順(少ない順)
Private Sub CommandButton1_Click()
    StrLenSort Range("A1").Column, xlAscending
End Sub

'// 文字数降順(多い順)
Private Sub CommandButton2_Click()
    StrLenSort Range("A1").Column, xlDescending
End Sub

'// 並べ替え処理関数
Sub StrLenSort(sortKeyCol, sortOrder)
    Columns(sortKeyCol + 1).Insert
    Dim lastRow As Long
    lastRow = Cells(Rows.Count, sortKeyCol).End(xlUp).Row
    For r = 1 To lastRow
        Cells(r, sortKeyCol + 1).Value = LenB(StrConv(Cells(r, sortKeyCol).Value, vbFromUnicode))
    Next
    Cells.Sort key1:=Cells(1, sortKeyCol + 1), order1:=sortOrder, _
               key2:=Cells(1, sortKeyCol), order2:=sortOrder
    Columns(sortKeyCol + 1).Delete
End Sub

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

こちらはおまけですが、先の質問のコメントで書いた置換を可変列にした例です。

コメントだと説明が見づらいので、こちらの回答に混ぜさせてもらいました。


EXCEL のシートを下記のようにしておいて、

  A B C D E F
1 入力文 置換1 置換2 置換3 置換4 変換結果
2 (動物)と(動物)は(可愛い)。だから(色)(動物)と(色)(動物)が(好き) (動物) (好き) (可愛い) (色)
3 (動物)と(動物)は(可愛い)。だから(色)(動物)と(色)(動物)が(好き) 好き かわいい 白い
4 (動物)と(動物)は(可愛い)。だから(色)(動物)と(色)(動物)が(好き) 大好き きれい 黒い
5 (動物)と(動物)は(可愛い)。だから(色)(動物)と(色)(動物)が(好き) おもしろい 縞の

下記のマクロで従来の変換が可能です。置換の列を任意に増やしても動作します。

1行目が「置換」という文字を含んでいる列が処理対象です。

同じく1行目に原文の「入力文」、と結果を書く「変換結果」のタイトルを置いてください。


Option Explicit

'// コマンドボタン処理
'//-----------------------------------
Private Sub CommandButton1_Click()
    Dim dstWS As Worksheet
    Set dstWS = ThisWorkbook.Sheets("Sheet1")
    
    Dim replaceArray() As Variant
    Dim searchWord() As Variant

    Dim rCount As Long
    rCount = 0
    
    Dim sourceCol
    sourceCol = 0
    
    Dim resultCol
    resultCol = 0
    
    Dim c As Long
    For c = 1 To Columns.Count
        If InStr(dstWS.Cells(1, c).Value, "置換") > 0 Then
            ReDim Preserve replaceArray(rCount)
            ReDim Preserve searchWord(rCount)
            replaceArray(rCount) = makeArray(dstWS.Range(dstWS.Cells(3, c).AddressLocal))
            searchWord(rCount) = dstWS.Cells(2, c).Value
            rCount = rCount + 1
        End If
        If InStr(dstWS.Cells(1, c).Value, "入力文") > 0 Then
            sourceCol = c
        End If
        If InStr(dstWS.Cells(1, c).Value, "変換結果") > 0 Then
            resultCol = c
        End If
    Next
    
    If sourceCol = 0 Then
        MsgBox "「入力文」の列がありません。"
        Exit Sub
    End If
    If resultCol = 0 Then
        MsgBox "「変換結果」の列がありません。"
        Exit Sub
    End If
    
    Dim CellA As Range
    Dim res As String
    Dim i As Long
    Set CellA = dstWS.Range(dstWS.Cells(2, sourceCol).AddressLocal)
    Do While CellA.Value <> ""
        res = CellA.Value
        For i = LBound(replaceArray) To UBound(replaceArray)
            res = replacePhrase(res, searchWord(i), replaceArray(i))
        Next
        dstWS.Cells(CellA.Row, resultCol).Value = res
        Set CellA = CellA.Offset(1, 0)
    Loop
End Sub

'// 配列を使用してランダムに置き換え
'//-----------------------------------
Function replacePhrase(phrase, searchWord, replaceArray)
    Dim pArray As Variant
    Dim arrayIndex As Long
    Dim i As Long
        
    '// 配列のシャッフル
    arrayIndex = 0
    shuffleArray replaceArray
    pArray = Split(phrase, searchWord)
    replacePhrase = pArray(0)
    For i = 1 To UBound(pArray)
        replacePhrase = replacePhrase & replaceArray(arrayIndex) & pArray(i)
        arrayIndex = arrayIndex + 1
        If arrayIndex > UBound(replaceArray) Then
    '// 一巡したら配列を再シャッフル
            arrayIndex = 0
            shuffleArray replaceArray
        End If
    Next
End Function

'// 指定したレンジから配列に作成
'//-----------------------------------
Function makeArray(baseRange As Range)
    Dim r As Range
    Dim res As String
    
    res = baseRange.Value
    Set r = baseRange.Offset(1, 0)
    
    Do While r.Value <> ""
        res = res & "/" & r.Value
        Set r = r.Offset(1, 0)
    Loop
    makeArray = Split(res, "/")
End Function

'// 配列の単語を並べ替える
'//-----------------------------------
Sub shuffleArray(wordArray)
    Dim r As Long
    r = UBound(wordArray)

    Dim i As Long, j As Long, s As Long, t As String
    For i = 1 To 3 '// 気持ちだけ多めにシャッフル:省略も可。
        For j = 0 To r
            s = Int(Rnd() * (r + 1))
            t = wordArray(s)
            wordArray(s) = wordArray(j)
            wordArray(j) = t
        Next
    Next
End Sub

ご参考までに。

id:egaosaiko

Mookさん

いつもありがとうございます。

またお世話になります。

まずは、昇順・降順のコードはさすがドンピシャでした。

私のしたいことそのままでした。

何度も試してしまいました。


そして、置換を可変列にしたランダム置換コード。

本当にほんとうにありがたいですね。

すごいとしか言えないエクセルの使い方です。

コードがあまりに美しい!

まだあまり試せていないのですが、

何度か実行して不具合や不明な点などあれば、

また「この質問・回答へコメントを書く」欄に書かせていただきます。

質問ページの枠を越えて教えていただき、とても嬉しいかぎりです。

また感動してしまいました!

2011/04/14 20:29:10
  • id:SALINGER
    書き忘れましたが、下から3行目コメントアウトしてる部分
    xlDescendingが降順の意味なので、昇順の場合はxlAscendingにしてください。
  • id:egaosaiko
    SALINGERさん

    ご丁寧にありがとうございます。

    >xlAscending
    昇順の場合にしても正確に動きました。
    補足情報たいへん助かります。
  • id:egaosaiko
    SALINGERさん Mookさん
    この度はお付き合いいただき、ありがとうございました。

    いろいろ迷ったあげく、

    巡り巡って先に2パターンお答えいただいた、
    SALINGERさんのお答えをベストアンサーとさせていただきました。

    また、
    個人的にこのページの質問以外の疑問にも長らく丁寧にお付き合いいただいているMookさんに、
    200pt差し上げることにしました。

    どうかよろしくおねがいいたします。
  • id:Mook
    本来の質問だけでしたら、私のは回答する必要の無い内容ですので
    ベストアンサーの適切な判断だと思います。

    ポイントはお気遣い頂きありがとうございます。
    今回はテーマがおもしろかったので、ついつい力が入ってしまいました。

    お役に立てば何よりです。
  • id:egaosaiko
    Mookさんへ

    上記で教えていただいた「ランダム置換」コードにおいて
    1つ分からないことがあるので、質問させてください(前回の質問のページで質問するべきかもですが)。

    「コマンドボタン処理」セクションの最下層では、

    Dim CellA As Range
    Dim res As String
    Dim i As Long
    Set CellA = dstWS.Range(dstWS.Cells(2, sourceCol).AddressLocal)
    Do While CellA.Value <> ""
    res = CellA.Value
    For i = LBound(replaceArray) To UBound(replaceArray)
    res = replacePhrase(res, searchWord(i), replaceArray(i))
    Next
    dstWS.Cells(CellA.Row, resultCol).Value = res
    Set CellA = CellA.Offset(1, 0)
    Loop
    End Sub


    ↑のように何度も「CellA」が使われていますが、
    たとえ「入力文(置換前の文章)」の列を、 A列→B列(または他の列) に変更したとしても、
    上記のコードのままでいいのでしょうか。

    仮に「入力文(置換前の文章)」の列を、A列→B列に変えた場合、
    コードも CellA→CellB に変更すると思ったのですが、

    実際に変更させずに(CellAのまま)試してみても、正常にランダム置換はされるみたいなので
    ここはMookさんのご意見をぜひお伺いしたいです。

    この「CellA」の意味についての説明を
    どうかよろしくおねがいします。


    それにしても、本当にすごく便利なVBAコードです^^
    「置換箇所」の列を増やすにしても、こんなに楽になるんですね!
  • id:SALINGER
    Mookさんじゃありませんが、見かけたので失礼します。
    1行目に
    Dim CellA As Range
    とありますでしょ。
    これは"CellA"という名前のRange型の変数を宣言するという意味です。
    変数とは入れ物のことで、入れ物の名前は何でもよく重要なのは中身ということになります。
    イメージとしてはこんな感じ
    http://pc.nikkeibp.co.jp/pc21/special/2007_gosa/eg1.shtml
     
    変数を使う目的の一つはまさに疑問にあるように、変更があった場合に
    変数に値を代入するところ
    Set CellA = dstWS.Range(dstWS.Cells(2, sourceCol).AddressLocal)
    さえ変えれば、他は変更せずに使えるということなんです。
  • id:egaosaiko
    SALINGERさん

    親切に
    ご返信ありがとうございます。

    変数についてのリンク助かります。
    図解されていたので、イメージはできました。

    ということは、

    CellAのところは、CellBでもCellCでも、はたまたRINGOでもなんでもよくて
    ただ自分でわかりやすいように、今回はCellAという宣言をしたということでしょうか。

    そして、
    >Set CellA = dstWS.Range(dstWS.Cells(2, sourceCol).AddressLocal)
    については必要とあれば
    Set CellA = dstWS.Range(dstWS.Cells(3, sourceCol).AddressLocal)
    など、行数を変えて使うというイメージでいいのでしょうか。
    もしそれが正解なら
    今のところ、行数を変えるつもりはないので、ここはまったく変更する必要がないという解釈に至りました。


    的外れだったら、ご指摘おねがいします。
  • id:SALINGER
    変数に使えない文字以外は何でもいいです。日本語でもOK。
    コード自体は今までの流れを知らないので全体で何をするコードかも知りませんが、
    部分的にはその解釈であっていると思います。
  • id:egaosaiko
    SALINGERさん

    ご返信ありがとうございます。

    変数は日本語でもいいというのは分かりやすくて便利な気がします。
    なぜか、日本語を使っているコードはあまり見たことないんですが。

    とりあえずは、的外れでなくてよかったです。
    ありがとうございます。
  • id:Mook
    コメントに気が付かなくてすみません。

    SALINGER さん、説明ありがとうございました。

    ほとんどの部分は、こちらで作り変えたのですが CellA だけは egaosaiko さんの
    オリジナルコードの名残です。
    任意のセルを処理するために使用しているので、特に変える必要も無かったため
    そのままとなっています。

    処理内容を変えるのは代入している右辺側なので、そちらだけ考慮すればよいです。
  • id:egaosaiko
    Mookさん

    コメントありがとうございます。

    そうですか^^
    疑問の発端は自分だったんですね!

    教えてくださり、とてもすっきりしました。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません