组合分解

lljd808

Qs18 发表于 2024-11-16 21:56
试试........

太贴心了，多谢指点！

Qs18

1. Sub qss()
   
2. With Sheet1
   
3.     arr = .Range("e1").CurrentRegion.Value
   
4.     ReDim Brr(1 To UBound(arr), 1 To 3)
   
5. For i = 2 To UBound(arr)
   
6.     ma = Application.Max(Application.Index(arr, i, 0))
   
7.     mi = Application.Min(Application.Index(arr, i, 0))
   
8.     x = 0
   
9.     For j = 2 To UBound(arr, 2)
   
10.         If arr(i, j) > 0 Then
    
11.             x = x + 1
    
12.         End If
    
13.     Next
    
14.    If x = 3 Then
    
15.         For j = 2 To UBound(arr, 2)
    
16.         If arr(i, j) > 0 Then
    
17.             Brr(i, 2) = Brr(i, 2) & arr(1, j)
    
18.         End If
    
19.     Next
    
20.    Brr(i, 2) = Brr(i, 2) & ma & "人"
    
21.    Else
    
22.         t = "": t2 = "": t3 = ""
    
23.         For j = 2 To UBound(arr, 2)
    
24.         If arr(i, j) > 0 Then
    
25.             If arr(i, j) = ma Then
    
26.                 t = t & arr(1, j)
    
27.             
    
28.             ElseIf arr(i, j) = mi Then
    
29.                 t2 = t2 & arr(1, j)
    
30.             Else
    
31.                 t3 = t3 & arr(1, j)
    
32.             End If
    
33.         End If
    
34.         Next
    
35.    Brr(i, 2) = t & t3 & ma - mi & "人，" & t & t2 & mi & "人"
    
36.    End If
    
37.     Brr(i, 1) = Val(arr(i, 1))
    
38.     Brr(i, 2) = Brr(i, 1) & "." & Brr(i, 2)
    
39.     Brr(i, 3) = ma
    
40. 
    
41. Next
    
42. Brr(1, 1) = "班级": Brr(1, 2) = "组合认识": Brr(1, 3) = "班人数"
    
43. .Range("a1").Resize(UBound(Brr), 3) = Brr
    
44. End With
    
45. End Sub

复制代码

Qs18

试试...............

Qs18

第二个功能

lljd808

Qs18 发表于 2024-11-16 22:55

成分感谢，超出预期！

lljd808

Qs18 发表于 2024-11-16 22:56
第二个功能

不由得由感谢变崇拜了，十分感激！