|
Sub tt1()
Dim A()
Set d = CreateObject("scripting.dictionary")
arr = [A3].CurrentRegion
For i = 2 To UBound(arr)
C1 = arr(i, 4) = "否": C2 = d.exists(arr(i, 3))
If C1 And C2 Then
A = d(arr(i, 3)): m = UBound(A)
m = m + 1
ReDim Preserve A(1 To m)
A(m) = arr(i, 5)
d(arr(i, 3)) = A
ElseIf C1 And Not C2 Then
ReDim A(1 To 1): A(1) = arr(i, 5)
d(arr(i, 3)) = A
End If
Next
'-----------------------------
Set B = Range([A4], [A4].End(4))
For i = 1 To B.Cells.Count
x1 = "": x2 = ""
Set s = B.Cells(i)
C3 = s.Offset(, 3) = "否"
tt = s.Offset(, 2): t1 = d(tt): t2 = d(tt)
BubbleSortDesc t1
BubbleSortASC t2
x1 = s.Offset(, 4)
'------------------------------------
For j = 1 To UBound(t1): If x1 = t1(j) Then x2 = j: Exit For
Next
If C3 And Len(x2) > 0 Then s.Offset(, 6) = x2
'------------------------------------
x2 = ""
For j = 1 To UBound(t2): If x1 = t2(j) Then x2 = j: Exit For
Next
If C3 And Len(x2) > 0 Then s.Offset(, 7) = x2
'------------------------------------
Next
End Sub
Sub BubbleSortASC(list) '1D array sort Asc sub sort 1D array
' Sorts an array using bubble sort algorithm
Dim First As Integer, Last As Long
Dim i As Long, j As Long
Dim Temp As Long
First = LBound(list)
Last = UBound(list)
For i = First To Last - 1
For j = i + 1 To Last
If list(i) > list(j) Then
Temp = list(j)
list(j) = list(i)
list(i) = Temp
End If
Next j
Next i
End Sub
Sub BubbleSortDesc(list) '1D array sort Desc sub sort 1D array
' Sorts an array using bubble sort algorithm
Dim First As Integer, Last As Long
Dim i As Long, j As Long
Dim Temp As Long
First = LBound(list)
Last = UBound(list)
For i = First To Last - 1
For j = i + 1 To Last
If list(i) < list(j) Then
Temp = list(j)
list(j) = list(i)
list(i) = Temp
End If
Next j
Next i
End Sub |
评分
-
1
查看全部评分
-
|