各位大侠帮帮忙，帮我处理一下随着数据改变而数据列自动排序调整！！！

chxw68

1. Sub test1()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("求助表格")
   
7.     arr = .Range("a2:o30")
   
8.     ReDim brr(1 To 2, 1 To 7)
   
9.     For j = 4 To 10
   
10.       brr(1, j - 3) = arr(2, j)
    
11.       For i = 3 To UBound(arr)
    
12.         If Len(arr(i, 3)) <> 0 Then
    
13.           If Len(arr(i, j)) <> 0 Then
    
14.             brr(2, j - 3) = brr(2, j - 3) + 1
    
15.           End If
    
16.         End If
    
17.       Next
    
18.     Next
    
19.     For i = 1 To UBound(brr, 2) - 1
    
20.       p = i
    
21.       For j = i + 1 To UBound(brr, 2)
    
22.         If brr(2, p) < brr(2, j) Then
    
23.           p = j
    
24.         End If
    
25.       Next
    
26.       If p <> i Then
    
27.         temp = brr(1, i)
    
28.         brr(1, i) = brr(1, p)
    
29.         brr(1, p) = temp
    
30.         temp = brr(2, i)
    
31.         brr(2, i) = brr(2, p)
    
32.         brr(2, p) = temp
    
33.       End If
    
34.     Next
    
35.     For j = 1 To 3
    
36.       .Cells(j + 12, 24) = brr(1, j)
    
37.       .Cells(j + 12, 25) = brr(2, j)
    
38.     Next
    
39.   End With
    
40. End Sub
    

复制代码

chxw68

又做了第2问和第3问，数据变化后你要点击一下按钮。

wj2368

教父01 发表于 2017-10-10 08:56
我想解决右侧那八个问题，红色说明部分！
主要是那几个排名！

。。。。。。。。。。。。。。

chxw68

1. Sub test3()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("求助表格")
   
7.     arr = .Range("a2:o30")
   
8.     ReDim brr(1 To 4, 1 To 7)
   
9.     For j = 4 To 10
   
10.       brr(1, j - 3) = arr(2, j)
    
11.       For i = 3 To UBound(arr)
    
12.         If Len(arr(i, 3)) <> 0 Then
    
13.           If Len(arr(i, j)) <> 0 Then
    
14.             brr(2, j - 3) = brr(2, j - 3) + 1
    
15.             If arr(i, j) >= 0 Then
    
16.               brr(3, j - 3) = brr(3, j - 3) + 1
    
17.             End If
    
18.           End If
    
19.         End If
    
20.       Next
    
21.     Next
    
22.     For j = 1 To UBound(brr, 2)
    
23.       brr(4, j) = Round(brr(3, j) / brr(2, j), 2)
    
24.     Next
    
25.     ReDim crr(1 To UBound(brr, 2))
    
26.     For j = 1 To UBound(brr, 2)
    
27.       crr(j) = Application.Index(brr, 0, j)
    
28.     Next
    
29.    
    
30.     For i = 1 To UBound(crr) - 1
    
31.       p = i
    
32.       For j = i + 1 To UBound(crr)
    
33.         If crr(p)(4, 1) < crr(j)(4, 1) Then
    
34.           p = j
    
35.         End If
    
36.       Next
    
37.       If p <> i Then
    
38.         temp = crr(i)
    
39.         crr(i) = crr(p)
    
40.         crr(p) = temp
    
41.       End If
    
42.     Next
    
43.     For j = 1 To 3
    
44.       .Cells(j + 17, 30) = crr(j)(1, 1)
    
45.       .Cells(j + 17, 31) = crr(j)(2, 1) & "战" & crr(j)(2, 1) - crr(j)(3, 1) & "负,胜率为" & crr(j)(4, 1)
    
46.       .Cells(j + 22, 24) = crr(UBound(crr) - j + 1)(1, 1)
    
47.       .Cells(j + 22, 25) = crr(UBound(crr) - j + 1)(2, 1) & "战" & crr(UBound(crr) - j + 1)(2, 1) - crr(UBound(crr) - j + 1)(3, 1) & "负,胜率为" & crr(UBound(crr) - j + 1)(4, 1)
    
48.     Next
    
49.   End With
    
50. End Sub
    
51. 
    

复制代码

chxw68

又做了第4问和第5问，请楼主测试。

教父01

wj2368 发表于 2017-10-10 11:10
。。。。。。。。。。。。。。

真厉害哦！就是这个意思！还请帮忙把后面几个问题帮助解答！
另外，如果增加行或者列的话该如何调整？

教父01

chxw68 发表于 2017-10-10 11:16
又做了第4问和第5问，请楼主测试。

辛苦了，谢谢！！！

wj2368

教父01 发表于 2017-10-10 11:21
真厉害哦！就是这个意思！还请帮忙把后面几个问题帮助解答！
另外，如果增加行或者列的话该如何调整？

...................

教父01

wj2368 发表于 2017-10-10 15:28
...................

非常感谢您的帮助！！！还请您多多费心！！！但是，好像第二个和第三个问题有些不太正确！麻烦您再帮着看看！！！

wj2368

教父01 发表于 2017-10-10 15:59
非常感谢您的帮助！！！还请您多多费心！！！但是，好像第二个和第三个问题有些不太正确！麻烦您再帮着看 ...

。。。。。。。。。。。。