ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
楼主: dsmch

[讨论] 随机男女配对

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-1-20 19:28 | 显示全部楼层
偶遇此贴,看到了我当年对函数公式的痴迷,谢谢你

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-1-20 21:04 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
本帖最后由 dsmch 于 2019-1-20 21:16 编辑

引申一下,男女女、男女女……女男男、女男男……不要想污了,不是3P,代码该如何写?
  1. Sub dsmch()
  2. arr = Range("a1").CurrentRegion
  3. For i = 2 To UBound(arr)
  4.     p = "": p3 = ""
  5.     For j = 2 To UBound(arr, 2) '单双(10)
  6.         p = p & arr(i, j) Mod 2
  7.     Next
  8.     If arr(i, 2) Mod 2 = 1 Then
  9.         zf = "100": GoSub 100
  10.         For j = 3 To Len(p2) Step 3
  11.            If Val(Mid(p2, j, 1)) - Val(Mid(p2, j - 2, 1)) < 0 And Val(Mid(p2, j - 1, 1)) - Val(Mid(p2, j - 2, 1)) < 0 Then p3 = p3 & " " & Mid(p2, j - 2, 3)
  12.         Next
  13.         p2 = Mid(p3, 2)
  14.     Else
  15.         zf = "011": GoSub 100
  16.         For j = 3 To Len(p2) Step 3
  17.           If Val(Mid(p2, j, 1)) - Val(Mid(p2, j - 2, 1)) > 0 And Val(Mid(p2, j - 1, 1)) - Val(Mid(p2, j - 2, 1)) > 0 Then p3 = p3 & " " & Mid(p2, j - 2, 3)
  18.         Next
  19.         p2 = Mid(p3, 2)
  20.     End If
  21.     Cells(i, "o") = p2
  22. Next
  23. Exit Sub
  24. 100:
  25. s = 1: p2 = ""
  26. Do Until s = 0
  27.     For k = 1 To Len(zf)
  28.         Z = Mid(zf, k, 1)
  29.         y = InStr(s, p, Z)
  30.         If y <> 0 Then p2 = p2 & arr(i, y + 1): s = y + 1 Else Exit Do
  31.     Next
  32. Loop
  33. Return
  34. End Sub
复制代码


奇偶配对解题88.rar

24.08 KB, 下载次数: 9

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2019-1-21 07:16 | 显示全部楼层
'跟你的示例结果不一样,我这结果看上去也没问题,,,

Option Explicit

Sub test()
  Dim arr, i, j, k, kk, 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
              For kk = k + 1 To UBound(arr, 2)
                If (arr(i, j) + arr(i, kk)) Mod 2 = 1 Then
                  If arr(i, j) Mod 2 = 0 Xor arr(i, j) > arr(i, kk) Then
                    s = s & Space(1) & arr(i, j) & arr(i, k) & arr(i, kk)
                    j = kk: k = UBound(arr, 2): Exit For
                  End If
                End If
              Next
              If kk = UBound(arr, 2) + 1 Then j = kk: Exit For
            End If
          End If
        Next
      End If
    Next
    arr(i, 1) = s: s = vbNullString
  Next
  [m2].Resize(UBound(arr, 1)) = arr
End Sub

评分

2

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-1-21 07:23 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
本帖最后由 dsmch 于 2019-1-21 07:24 编辑
一把小刀闯天下 发表于 2019-1-21 07:16
'跟你的示例结果不一样,我这结果看上去也没问题,,,

Option Explicit

按原帖规则,第一个结果526,因6大于5,该组结果无效,往后重新组合

TA的精华主题

TA的得分主题

发表于 2019-1-21 12:12 | 显示全部楼层
dsmch 发表于 2019-1-21 07:23
按原帖规则,第一个结果526,因6大于5,该组结果无效,往后重新组合

按12楼附件来写的,试了一下没有问题

只是当进入第三个人判断时会出现二种情况,当成功时 j=kk+1重新查找下一个没有问题,但当失败时 j=j+1开始判断比较合理,所以觉得应该去除下行更靠谱些:
If kk = UBound(arr, 2) + 1 Then j = kk: Exit For

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-1-21 12:47 | 显示全部楼层
一把小刀闯天下 发表于 2019-1-21 12:12
按12楼附件来写的,试了一下没有问题

只是当进入第三个人判断时会出现二种情况,当成功时 j=kk+1重新 ...

考虑到代码的通用性,几人组合就用几重循环并不可取,如3人以上组合……闲暇无事,权当练练手,碰到类似问题以后有个借鉴,谢谢参与!

TA的精华主题

TA的得分主题

发表于 2019-1-21 15:59 | 显示全部楼层
再来一篇作文,试了一下,不知是否有错误
  1. Sub qq()
  2. Dim arr, r%, i%, j%, m%, s$, x2%, x3%
  3. Dim brr() As String, x%, s1$, x1$, s2$
  4. x1 = InputBox("请输入组合数")
  5. r = Cells(1, 1).End(xlDown).Row
  6. arr = Range("b2:k" & r)
  7. ReDim brr(1 To UBound(arr), 1 To 1)
  8. For i = 1 To UBound(arr)
  9. s = "": x = 0
  10. m = arr(i, 1) Mod 2
  11. For j = 1 To UBound(arr, 2)
  12. If j = 1 Or s = "" And arr(i, j) Mod 2 = m Then
  13. x = x + 1: s = arr(i, j)
  14. Else
  15. If arr(i, j) Mod 2 <> m And s <> "" Then
  16. x = x + 1: s = s & arr(i, j)
  17. If x = Val(x1) Then
  18. If m Then
  19. For x2 = 2 To Len(s)
  20. If Val(Mid(s, x2, 1)) < Val(Left(s, 1)) Then x3 = x3 + 1
  21. Next
  22. If x3 = Val(x1) - 1 Then
  23. s2 = s2 & " " & s
  24. End If
  25. Else
  26. For x2 = 2 To Len(s)
  27. If Val(Mid(s, x2, 1)) > Val(Left(s, 1)) Then x3 = x3 + 1
  28. Next
  29. If x3 = Val(x1) - 1 Then
  30. s2 = s2 & " " & s
  31. End If
  32. End If
  33. x = 0: s = "": x3 = 0
  34. End If
  35. End If
  36. End If
  37. Next
  38. brr(i, 1) = Mid(s2, 2): s2 = ""
  39. Next
  40. [n2].Resize(UBound(brr)).Clear
  41. [n2].Resize(UBound(brr)) = brr
  42. End Sub


复制代码
奇偶配对解题88.rar (26.05 KB, 下载次数: 5)

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2019-1-21 16:02 | 显示全部楼层
一大堆的循环加判断,呵呵。。。。。。。。。。。。。。。

TA的精华主题

TA的得分主题

发表于 2019-1-21 20:22 | 显示全部楼层
  1. Sub test()
  2. Dim arr, k1, k2
  3. k1 = [a1].End(4).Row - 1
  4. k2 = [a2].End(2).Column - 1
  5. arr = [b2].Resize(k1, k2)

  6. Dim brr()
  7. ReDim brr(1 To k1, 1 To 1)

  8. For i = 1 To k1
  9. txt = "A"
  10. For j = 1 To k2
  11.     txt = txt & arr(i, j)
  12. Next j

  13. With CreateObject("vbscript.regexp")
  14.     .Global = True
  15.     If Mid(txt, 2, 1) Mod 2 = 1 Then .Pattern = "[13579]+[02468]" Else .Pattern = "[02468]+[13579]"
  16.     If .test(txt) Then
  17.         k3 = .Execute(txt).Count - 1
  18.          brr(i, 1) = "'"
  19.         For j = 0 To k3
  20.             txt2 = .Execute(txt)(j)
  21.             If Mid(txt, 2, 1) Mod 2 = 1 Then
  22.                If Left(txt2, 1) > Right(txt2, 1) Then brr(i, 1) = brr(i, 1) & " " & Left(txt2, 1) & Right(txt2, 1)
  23.             Else
  24.                If Left(txt2, 1) < Right(txt2, 1) Then brr(i, 1) = brr(i, 1) & " " & Left(txt2, 1) & Right(txt2, 1)
  25.             End If
  26.         Next j
  27.     End If
  28. End With

  29. Next i

  30. [n2].Resize(k1, 1) = brr
  31. End Sub
复制代码
加点正则处理

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2019-1-22 11:12 | 显示全部楼层
搞这么复杂干嘛,直接按照规则写不就完事了。
  1. Sub grf()
  2.     arr = Range("b2:k24")
  3.     For i = 1 To UBound(arr)
  4.         k = arr(i, 1) Mod 2
  5.         s = ""
  6.         For j1 = 1 To UBound(arr, 2) - 1
  7.             a = arr(i, j1)
  8.             For j2 = j1 + 1 To UBound(arr, 2)
  9.                 b = arr(i, j2)
  10.                 If a Mod 2 = k And b Mod 2 <> k Then
  11.                     If (k = 1 And a > b) Or (k = 0 And a < b) Then s = s & " " & a & b
  12.                     j1 = j2
  13.                     Exit For
  14.                 End If
  15.             Next
  16.             Cells(i + 1, "N") = "'" & Mid(s, 2)
  17.         Next
  18.     Next
  19. End Sub
复制代码
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 19:24 , Processed in 0.052585 second(s), 8 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表