Excel VBA質問箱 IV

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

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


39218 / 76732 ←次へ | 前へ→

【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

#アルゴリズムとかはよくわかってないので見ようみまねです^ ^;

0 hits

【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 お礼

39218 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free