人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

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コードの分かる方、書ける方がいましたら
どうかよろしくおねがいします。


●質問者: ヘンリ
●カテゴリ:コンピュータ ウェブ制作
✍キーワード:A1 Excel VBA いもの エクセル
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● SALINGER
●100ポイント ベストアンサー

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

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

◎質問者からの返答

SALINGERさん

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

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

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

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

ありがたいですね!


2 ● Mook
●200ポイント

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


'// 文字数昇順(少ない順)
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

ご参考までに。

◎質問者からの返答

Mookさん

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

またお世話になります。

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

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

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


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

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

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

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

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

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

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

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

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

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ