随机男女配对

dsmch · 发表于 2019-1-19 19:37

最近在开放式竞赛专区看到一函数竞赛题，感到很有意思，请喜爱VBA的坛友试试练练手
http://club.excelhome.net/forum. ... peid%26typeid%3D102

dsmch · 发表于 2019-1-19 19:39

抛砖引玉，先贴出我的代码

Sub dsmch()
arr = Range("a1").CurrentRegion
For i = 2 To UBound(arr)
p = "": p3 = ""
For j = 2 To UBound(arr, 2) '单双(10)
p = p & arr(i, j) Mod 2
Next
If arr(i, 2) Mod 2 = 1 Then
zf = "10": GoSub 100
For j = 2 To Len(p2) Step 2
If Val(Mid(p2, j, 1)) - Val(Mid(p2, j - 1, 1)) < 0 Then p3 = p3 & " " & Mid(p2, j - 1, 2)
Next
p2 = Mid(p3, 2)
Else
zf = "01": GoSub 100
For j = 2 To Len(p2) Step 2
If Val(Mid(p2, j, 1)) - Val(Mid(p2, j - 1, 1)) > 0 Then p3 = p3 & " " & Mid(p2, j - 1, 2)
Next
p2 = Mid(p3, 2)
End If
Cells(i, "o") = p2
Next
Exit Sub
100:
s = 1: p2 = ""
Do Until s = 0
For k = 1 To Len(zf)
Z = Mid(zf, k, 1)
y = InStr(s, p, Z)
If y <> 0 Then p2 = p2 & arr(i, y + 1): s = y + 1 Else Exit Do
Next
Loop
Return
End Sub

复制代码

一把小刀闯天下 · 发表于 2019-1-19 20:15

本帖最后由一把小刀闯天下于 2019-1-20 10:04 编辑

'示例有问题的吧，，，
=========
'按规则修改了一下：

Option Explicit

Sub test()
  Dim arr, i, j, k, s As String
  arr = [b2:k25]
  For i = 1 To UBound(arr, 1)
For j = 1 To UBound(arr, 2)
   If (arr(i, 1) + arr(i, j)) Mod 2 = 0 Then
      For k = j + 1 To UBound(arr, 2)
      If (arr(i, j) + arr(i, k)) Mod 2 = 1 Then
         If arr(i, j) Mod 2 = 0 Xor arr(i, j) > arr(i, k) Then s = s & Space(1) & arr(i, j) & arr(i, k)
         j = k: Exit For
      End If
      Next
   End If
Next
arr(i, 1) = s: s = vbNullString
  Next
  [m2].Resize(UBound(arr, 1)) = arr
End Sub

dsmch · 发表于 2019-1-19 20:48

一把小刀闯天下发表于 2019-1-19 20:15
'示例有问题的吧，，，
Option Explicit

数字代表年龄，单数为男，双数为女，配对的男女，男的年龄大于女的年龄。单数开始的配对单双、单双……
双数开始的配对双单、双单…………

micch · 发表于 2019-1-19 21:29

Sub biandui()
Dim arr(23)
brr = [b2:k25]
For i = 1 To 24
br = Array("", "", "", "", "", "", "", "", "", "")
n = 0: br(n) = brr(i, 1)
For k = 2 To 10
If Val(brr(i, k) + brr(i, k - 1)) Mod 2 Then n = n + 1: br(n) = brr(i, k)
Next
For k = 1 To 9 Step 2
If Val(br(0)) Mod 2 And br(k) < br(k - 1) Or Val(br(0)) Mod 2 = 0 And br(k) > br(k - 1) And br(k) <> "" Then x = x & br(k - 1) & br(k) & " "
Next
arr(m) = x: x = "": m = m + 1
Next
[n2:n25] = Application.Transpose(arr)
End Sub

复制代码

micch · 发表于 2019-1-19 21:30

直接引用区域，总觉得应该有简单的办法，代码比函数写的还复杂

一把小刀闯天下 · 发表于 2019-1-19 21:46

dsmch 发表于 2019-1-19 20:48
数字代表年龄，单数为男，双数为女，配对的男女，男的年龄大于女的年龄。单数开始的配对单双、单双……
...

嗯，找了一下规律是这样的。如果行开始男女不限后面条件相同不晓得公式是否能解决。我不会公式，就算单数开始要用公式去解决也是挺难想象的。

dsmch · 发表于 2019-1-20 06:10

micch 发表于 2019-1-19 21:29

Val(brr(i, k) + brr(i, k - 1)) Mod 2
这个判断用得好！赞一个

dsmch · 发表于 2019-1-20 06:25

本帖最后由 dsmch 于 2019-1-20 08:30 编辑

一把小刀闯天下发表于 2019-1-19 21:46
嗯，找了一下规律是这样的。如果行开始男女不限后面条件相同不晓得公式是否能解决。我不会公式，就算单数 ...

有同感！原以为，函数能做到的，用VBA是小菜一碟。细想一下，函数就是用的固化后自定义函数和api函数，和vba彼此不分家

ykqrs · 发表于 2019-1-20 19:25

还是VBA好，循环加判断，楼上几位老师的代码很精简，我来篇作文

Sub qq()
Dim arr, r%, i%, j%, m%, s$, brr() As String
r = Cells(Rows.Count, 1).End(xlUp).Row
arr = Range("b2:k" & r)
ReDim brr(1 To UBound(arr), 1 To 1)
For i = 1 To UBound(arr)
m = arr(i, 1) Mod 2: s = arr(i, 1)
For j = 2 To UBound(arr, 2)
If s = "" And arr(i, j) Mod 2 = m Then s = arr(i, j)
If arr(i, j) Mod 2 <> m Then
If m Then
If Val(s) > arr(i, j) And s <> "" Then
brr(i, 1) = brr(i, 1) & " " & s & arr(i, j)
s = ""
Else
s = ""
End If
Else
If Val(s) < arr(i, j) And s <> "" Then
brr(i, 1) = brr(i, 1) & " " & s & arr(i, j)
s = ""
Else
s = ""
End If
End If
End If
Next
Next
[n2].Resize(UBound(brr)).Clear
[n2].Resize(UBound(brr)) = brr
End Sub

复制代码

		自动登录	找回密码
密码			免费注册

[讨论] 随机男女配对

评分

评分

评分

评分

最新热点 /1