[已解决]vba难题如何配对

laoau138

vba难题如何配对

最佳答案

月排行榜 / 总排行榜

grf1973

2017-3-27 15:06

1. Sub tt()
   
2.     arr = [a1].CurrentRegion
   
3.     Dim brr(1 To 6), crr(1 To 6)
   
4.     For i = 2 To UBound(arr)
   
5.         x = arr(i, 3)
   
6.         If arr(i, 2) = "男" Then
   
7.             brr(x) = brr(x) & "," & arr(i, 1)
   
8.         Else
   
9.             crr(x) = crr(x) & "," & arr(i, 1)
   
10.         End If
    
11.     Next
    
12.     ReDim drr(1 To UBound(arr) / 2, 1 To 2)
    
13.     For i = 1 To 6
    
14.         xrr = Split(brr(i), ",")
    
15.         yrr = Split(crr(7 - i), ",")
    
16.         For k = 1 To Application.Min(UBound(xrr), UBound(yrr))
    
17.             n = n + 1
    
18.             drr(n, 1) = xrr(k)
    
19.             drr(n, 2) = yrr(k)
    
20.         Next
    
21.     Next
    
22.     [e2].Resize(n, 2) = drr
    
23.     [e2].Resize(n, 2).Sort key1:=[e2]
    
24. End Sub

复制代码

跳转到最佳答案楼层

laoau138

谁来做一下

大灰狼1976

运行时间较长。

1. Sub aaa()
   
2. Dim arr, brr, i&, k&, r&
   
3. arr = [a1].CurrentRegion
   
4. brr = Range("h1:i" & (UBound(arr) - 1) / 2)
   
5. For i = 2 To UBound(arr) - 1
   
6.   If arr(i, 2) <> "" Then
   
7.     For k = i + 1 To UBound(arr)
   
8.       If arr(i, 2) <> arr(k, 2) And arr(k, 2) <> "" Then If arr(i, 3) + arr(k, 3) = 7 Then Exit For
   
9.     Next k
   
10.     If k <= UBound(arr) Then
    
11.       r = r + 1
    
12.       If arr(i, 2) = "男" Then
    
13.         brr(r, 1) = arr(i, 1)
    
14.         brr(r, 2) = arr(k, 1)
    
15.       Else
    
16.         brr(r, 1) = arr(k, 1)
    
17.         brr(r, 2) = arr(i, 1)
    
18.       End If
    
19.       arr(k, 2) = ""
    
20.     End If
    
21.   End If
    
22. Next i
    
23. [e2].Resize(UBound(brr), 2) = brr
    
24. MsgBox "剩余 " & UBound(arr) - 1 - r * 2 & " 人无法配对。"
    
25. End Sub

复制代码

grf1973

1. Sub tt()
   
2.     arr = [a1].CurrentRegion
   
3.     Dim brr(1 To 6), crr(1 To 6)
   
4.     For i = 2 To UBound(arr)
   
5.         x = arr(i, 3)
   
6.         If arr(i, 2) = "男" Then
   
7.             brr(x) = brr(x) & "," & arr(i, 1)
   
8.         Else
   
9.             crr(x) = crr(x) & "," & arr(i, 1)
   
10.         End If
    
11.     Next
    
12.     ReDim drr(1 To UBound(arr) / 2, 1 To 2)
    
13.     For i = 1 To 6
    
14.         xrr = Split(brr(i), ",")
    
15.         yrr = Split(crr(7 - i), ",")
    
16.         For k = 1 To Application.Min(UBound(xrr), UBound(yrr))
    
17.             n = n + 1
    
18.             drr(n, 1) = xrr(k)
    
19.             drr(n, 2) = yrr(k)
    
20.         Next
    
21.     Next
    
22.     [e2].Resize(n, 2) = drr
    
23.     [e2].Resize(n, 2).Sort key1:=[e2]
    
24. End Sub

复制代码