Excel VBA質問箱 IV

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

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


39263 / 76738 ←次へ | 前へ→

【42590】Re:並び替えの件で・・・
回答  だるま WEB  - 06/9/15(金) 20:19 -

引用なし
パスワード
   私もひとつ作ってみました。^d^

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

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は1次元限定。
  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
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 お礼

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