| |
私もひとつ作ってみました。^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
|
|
だるま
- 06/9/15(金) 20:19 -
