| |
「数値を大きい順に順位を割り当てる方法に」？とは、
もしかすると、Rankを割り当てる此方の方？
Option Explicit
Sub Main_2()
Dim vntA As Variant
Dim vntB As Variant
Dim vntC As Variant
Dim vntD As Variant
vntA = 1
vntB = 2
vntC = 2
vntD = 4
MsgBox GetRank(vntA, vntB, vntC, vntD)
End Sub
Private Function GetRank(ParamArray vntData() As Variant) As String
Dim i As Long
Dim strData As String
Dim vntSort As Variant
Dim lngIndex() As Long
Dim lngRank As Long
vntSort = vntData
ReDim lngIndex(UBound(vntData))
For i = 0 To UBound(vntData)
lngIndex(i) = i
Next i
ShellSort vntSort, lngIndex
lngRank = 1
vntSort(lngIndex(0)) = lngRank
For i = 1 To UBound(vntSort)
If vntData(lngIndex(i)) <> vntData(lngIndex(i - 1)) Then
lngRank = i + 1
End If
vntSort(lngIndex(i)) = lngRank
Next i
For i = 0 To UBound(vntSort)
If strData <> "" Then
strData = strData & "&"
End If
strData = strData & vntSort(i)
Next i
GetRank = strData
End Function
Private Sub ShellSort(vntList As Variant, _
lngIndex() As Long)
Dim i As Long
Dim j As Long
Dim lngGap As Long
Dim lngTmp As Long
Dim lngTop As Long
Dim lngEnd As Long
lngTop = LBound(lngIndex, 1)
lngEnd = UBound(lngIndex, 1)
lngGap = 1
Do While lngGap < (lngEnd - lngTop + 1) \ 3
lngGap = 3 * lngGap + 1
Loop
Do Until lngGap <= 0
For i = lngGap + lngTop To lngEnd
For j = i To lngGap + lngTop Step -lngGap
If vntList(lngIndex(j - lngGap)) <= vntList(lngIndex(j)) Then
lngTmp = lngIndex(j - lngGap)
lngIndex(j - lngGap) = lngIndex(j)
lngIndex(j) = lngTmp
Else
Exit For
End If
Next j
Next i
lngGap = lngGap \ 3
Loop
End Sub
|
|
Hirofumi
- 08/11/25(火) 21:21 -
