Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
6864 / 13646 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【42581】並び替えの件で・・・ kouka 06/9/15(金) 16:00 質問[未読]
【42583】Re:並び替えの件で・・・ Kein 06/9/15(金) 16:57 回答[未読]
【42608】Re:並び替えの件で・・・ Kein 06/9/16(土) 12:47 回答[未読]
【42590】Re:並び替えの件で・・・ だるま 06/9/15(金) 20:19 回答[未読]
【42603】Re:並び替えの件で・・・ ichinose 06/9/16(土) 11:13 回答[未読]
【42607】Re:並び替えの件で・・・ Ned 06/9/16(土) 12:38 発言[未読]
【42629】Re:並び替えの件で・・・ Ned 06/9/16(土) 23:10 発言[未読]
【42675】Re:並び替えの件で・・・ kouka 06/9/19(火) 10:14 お礼[未読]
【42581】並び替えの件で・・・
質問  kouka  - 06/9/15(金) 16:00 -
引用なし
パスワード
   お世話になります。
koukaです。

例えば、下記のようなｺｰﾄﾞが並んでいて・・・
ABC111
ABCD123
ABC111
ABC555
ABC555

並び替えをすると・・・
ABC111
ABC111
ABCD123
ABC555
ABC555

の順に並び替えたいのです。
法則は最後の3桁の数字で順番を決めます。
そこでRIGHT関数で並び替えようと思って、
Selection.Sort Key1:=Right(Range("A1",3)), Order1:=xlAscending
と、やってみましたが、エラーになっちゃいました。
例えば、B列にRIGHT関数で下3桁の情報を入れてから、
並び替えをすればいいのかもしれませんが、
もし、そんなことをしなくても1つのセルの中で出来るよ、
というのでのであれば、教えてください。
よろしくお願いします。
【42583】Re:並び替えの件で・・・
回答  Kein  - 06/9/15(金) 16:57 -
引用なし
パスワード
   結論から言うと、作業列を使ってRIGHT関数で数値の部分を抜き出すやりかたの方が
ずっと簡単・明瞭に処理できると思います。
もしどうしてもマクロ内部で並べ替えしたければ、仮にアクティブシートの
A1 から A列　にデータが並んでいるとして・・

Sub Test_MyDataSort()
　　Dim Ary() As Integer
　　Dim St As String
　　Dim LR As Long, i As Long, j As Long
　　Dim buf As Variant, vElm As Variant

　　LR = Range("A65536").End(xlUp).Row
　　ReDim Ary(1 To LR)
　　For i = 1 To LR
　　　 Ary(i) = CInt(Right(Cells(i, 1).Value, 3))
　　Next i
　　buf = Array_Sort(Ary())
　　For j = 1 To LR
　　　 With Cells(j, 1)
　　　　　St = Left$(.Value, Len(.Value) - 3)
　　　　　.Value = St & buf(j)
　　　 End With
　　Next j
End Sub

Private Function Array_Sort(ByVal NotSortedArry As Variant) As Variant
　　Dim i As Long, j As Long
　　Dim vElm As Variant

　　For i = LBound(NotSortedArry) To UBound(NotSortedArry)
　　　 For j = i + 1 To UBound(NotSortedArry)
　　　　　If NotSortedArry(i) > NotSortedArry(j) Then
　　　　　　 vElm = NotSortedArry(j)
　　　　　　 NotSortedArry(j) = NotSortedArry(i)
　　　　　　 NotSortedArry(i) = vElm
　　　　　End If
　　　 Next
　　Next
　　Array_Sort = NotSortedArry
End Function

というマクロで出来ます。見てのとおり、かなり複雑なコードです。
ちなみにこの配列内ソートのロジックは、コロスケさんのサイト↓を
参考にさせていただきました。(と言うより丸写しですが・・すいません)
http://puremis.net/excel/code/022.shtml
【42590】Re:並び替えの件で・・・
回答  だるま WEB  - 06/9/15(金) 20:19 -
引用なし
パスワード
   私もひとつ作ってみました。^d^

処理概要は次のとおりです。
１．各セルから右３文字を配列に取り出す
２．その配列を使って昇順の並べ替えインデックス配列を得る
３．そのインデックスを使って別の配列へセルから値を取り出す
４．その並べ替えられた配列の値をセルに書き戻す

Sub test()
　　Dim RR As Range
　　Dim R As Range
　　Dim VV As Variant
　　Dim Idx As Variant
　　Dim V2 As Variant
　　Dim i As Long
　　
　　Set RR = Range("A1")
　　Set RR = Range(RR, RR.End(xlDown))
　　
　　ReDim VV(1 To RR.Rows.Count)
　　
　　For Each R In RR
　　　　i = i + 1
　　　　VV(i) = Val(Right$(R.Value, 3))
　　Next
　　
　　Idx = MsCombSortI(VV)
　　
　　ReDim V2(1 To UBound(Idx), 1 To 1)
　　For i = 1 To UBound(Idx)
　　　　V2(i, 1) = RR.Cells(Idx(i)).Value
　　Next
　　RR.Value = V2
　　
End Sub

Private Function MsCombSortI(Target As Variant) As Variant
　　'昇順インデックスを返す。
　　'配列引数Targetは１次元限定。
　　Dim Idx() As Long
　　Dim L As Long
　　Dim U As Long
　　Dim i As Long
　　Dim gap As Long
　　Dim Temp As Long
　　Dim F As Boolean
　　
　　L = LBound(Target)
　　U = UBound(Target)
　　
　　'インデックス初期設定
　　ReDim Idx(L To U)
　　For i = L To U
　　　　Idx(i) = i
　　Next
　　
　　gap = U - L
　　F = True
　　
　　'並べ替え
　　Do While gap > 1 Or F = True
　　　　gap = Int(gap / 1.3)
　　　　If gap = 9 Or gap = 10 Then
　　　　　　gap = 11
　　　　ElseIf gap < 1 Then
　　　　　　gap = 1
　　　　End If
　　　　F = False
　　　　For i = L To U - gap
　　　　　　If Target(Idx(i)) > Target(Idx(i + gap)) Then　'降順時は <
　　　　　　　　Temp = Idx(i)
　　　　　　　　Idx(i) = Idx(i + gap)
　　　　　　　　Idx(i + gap) = Temp
　　　　　　　　F = True
　　　　　　ElseIf Target(Idx(i)) = Target(Idx(i + gap)) Then
　　　　　　　　If Idx(i) > Idx(i + gap) Then　 '昇順降順変更しても変更の必要なし
　　　　　　　　　　Temp = Idx(i)
　　　　　　　　　　Idx(i) = Idx(i + gap)
　　　　　　　　　　Idx(i + gap) = Temp
　　　　　　　　　　F = True
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　Loop

　　MsCombSortI = Idx()
　　
End Function
【42603】Re:並び替えの件で・・・
回答  ichinose  - 06/9/16(土) 11:13 -
引用なし
パスワード
   おはようございます。

私もKeinさんの

>作業列を使ってRIGHT関数で数値の部分を抜き出すやりかたの方が
>ずっと簡単・明瞭に処理できると思います。

に賛成です。だって、Excelならではですからねえ！！

学校の課題とかでなければ・・・、
>
>例えば、下記のようなｺｰﾄﾞが並んでいて・・・
>ABC111
>ABCD123
>ABC111
>ABC555
>ABC555
>
>並び替えをすると・・・
>ABC111
>ABC111
>ABCD123
>ABC555
>ABC555
上記のデータがアクティブシートのセルＡ1から並んでいるとすると、


標準モジュールに
'=================================================================
Sub test()
　　Dim idx As Variant
　　Dim g0 As Long
　　Dim in_alpha As Variant
　　Dim only_num As Variant
　　Dim addr As String
　　addr = Range("a1", Cells(Rows.Count, "a").End(xlUp)).Address
　　in_alpha = Application.Transpose(Range("a1", Cells(Rows.Count, "a").End(xlUp)).Value)
　　only_num = Evaluate("=transpose(value(right(" & addr & ",3)))")
　　For g0 = 1 To UBound(only_num)
　　　 With Application
　　　　　idx = .Match(.Min(only_num), only_num, 0)
　　　　　End With
　　　 Cells(g0, "a").Value = in_alpha(idx)
　　　 only_num(idx) = ""
　　　 Next
End Sub

こんな方法もあります。
（ソートのアルゴリズムの課題なら、
この方法は駄目・・・、と言われますけどね！！）

試してみてください。

デワ2.☆彡
【42607】Re:並び替えの件で・・・
発言  Ned  - 06/9/16(土) 12:38 -
引用なし
パスワード
   ▼kouka さん：
こんにちは。思いつきのしょもない案ですが

Sub sample()
　　Dim r As Range
　　With Range("A1", Range("A65536").End(xlUp))
　　　　For Each r In .Cells
　　　　　　r.Phonetic.Text = Right$(r.Value, 3)
　　　　Next r
　　　　.Sort Key1:=.Cells(1), Order1:=xlAscending, SortMethod:=xlPinYin
　　End With
End Sub
【42608】Re:並び替えの件で・・・
回答  Kein  - 06/9/16(土) 12:47 -
引用なし
パスワード
   あー・・すいません。先に提示したコードでは、数値の並び替えは
出来ますが、並び替える前の文字列と単純に繋げてしまったため、
インチキな処理結果になってしまいました。
で、やはり便利なExcelのSort機能を使うことにして、以下のような
コードに変更します。今度は「いったん数値部分をデータの前に持ってくる」
だけです。それで並び替えはうまくいきますから、もう一度ループして
元のように"文字列+3桁の数値"に戻します。作業列を使わずにやるとすれば、
おそらく最もシンプルなコードになると思います。

Sub Test_MyDataSort2()
　 Dim MyR As Range, C As Range
　 Dim Lg As Integer
　
　 Set MyR = Range("A1", Range("A65536").End(xlUp))
　 For Each C In MyR
　　　Lg = Len(C.Value) - 3
　　　C.Value = Right(C.Value, 3) & Left(C.Value, Lg)
　 Next
　 MyR.Sort Key1:=MyR.Cells(1), Order1:=xlAscending, _
　 Header:=xlGuess, Orientation:=xlSortColumns
　 For Each C In MyR
　　　Lg = Len(C.Value) - 3
　　　C.Value = Right(C.Value, Lg) & Left(C.Value, 3)
　 Next
　 Set MyR = Nothing
End Sub
【42629】Re:並び替えの件で・・・
発言  Ned  - 06/9/16(土) 23:10 -
引用なし
パスワード
   参考出品。配列とクイックソートで試してみました。

Sub sample()
　　Dim v()
　　Dim y As Long
　　Dim i As Long

　　With Range("A1", Range("A65536").End(xlUp))
　　　　v = .Resize(, 2).Value
　　　　y = UBound(v)
　　　　For i = 1 To y
　　　　　　v(i, 2) = Right$(v(i, 1), 3)
　　　　Next i
　　　　Call QArysort(v, 1, y, 1, 2, 2)
　　　　ReDim Preserve v(1 To y, 1 To 1)
　　　　.ClearContents
　　　　.Value = v
　　End With
End Sub

Private Sub QArysort(ByRef Ary() As Variant, _
　　　　　　　　　　 ByVal Lo As Long, ByVal Up As Long, _
　　　　　　　　　　 ByVal Li As Long, ByVal Ui As Long, _
　　　　　　　　　　 ByVal Cn As Long)
　　Dim tmpary()
　　Dim ac As Long
　　Dim i As Long, j As Long
　　Dim x As Long
　　
　　If Lo >= Up Then Exit Sub
　　ac = Ary((Up + Lo) \ 2, Cn)
　　i = Lo - 1
　　j = Up + 1
　　Do
　　　　ReDim tmpary(Li To Ui)
　　　　Do
　　　　　　i = i + 1
　　　　Loop While Ary(i, Cn) < ac
　　　　Do
　　　　　　j = j - 1
　　　　Loop While Ary(j, Cn) > ac
　　　　If i >= j Then Exit Do
　　　　For x = Li To Ui
　　　　　　tmpary(x) = Ary(j, x)
　　　　　　Ary(j, x) = Ary(i, x)
　　　　　　Ary(i, x) = tmpary(x)
　　　　Next x
　　Loop
　　If i - Lo > 1 Then QArysort Ary, Lo, i - 1, Li, Ui, Cn
　　If Up - j > 1 Then QArysort Ary, j + 1, Up, Li, Ui, Cn
End Sub

#アルゴリズムとかはよくわかってないので見ようみまねです^ ^;
【42675】Re:並び替えの件で・・・
お礼  kouka  - 06/9/19(火) 10:14 -
引用なし
パスワード
   皆さん、こんにちは。
お世話になります。

皆さんのコードを私が理解(できてるかもわかりませんが・・・）するのに、
だいぶ時間がかかりました(^^;)
作業列を使わなくても並び替えが出来る事がわかったので、
使ってみようと思います。
ありがとうございました。

ちなみに私は立派な(?)社会人でっす。。。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
6864 / 13646 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free