Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 1628|回复: 13

【求助】使用VBA写一个两两对抗的算法

[复制链接]
发表于 2021-11-27 09:53 | 显示全部楼层 |阅读模式
本帖最后由 浪子神剑 于 2021-11-29 18:05 编辑

1. 有A、B两组人员(各10人),分别为A1-A10,B1-B10
2. AB两组人员两两组合成搭档(A组和B组组合),即A1B1/A1B2/A1B3...A10B10总共10 * 10 = 100种组合
3. 把这100个组合进行两两对抗,即:A1B1 vs A2B1...
4. 要求:
        每一个人,他的对手,不能包含自己,如:A1B1 vs A1B2,这是不行的,因为两边都有A1
        每一个人,他的搭档不能重复出现,即A1和B1搭过了,就不能再搭了,所以每个人都会有10个不同的搭档
        每一个人,他的对手至少出现一次,最多只能出现两次
5. 最后输出结果:A1B1-A2B2, A1B2-A2B3...
        
求使用VBA计算出这类是如何排列的,最好能写成通用算法,比如后续扩展到AB两组各6人、8人、12人、14人...
我写了个检测结果的页面,可以把结果复制到里面检测
http://web.haizlin.cn/test/check.html

非常感谢!非常感谢!非常感谢!
        



excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2021-11-27 18:38 | 显示全部楼层
老铁,我尽力了,一般最后几个对数,没有想到办法处理不出现重复的,但是 也不难,自己手动调一下就可以了。下图C列为效果展示
代码如下,附件如下,直接可以使用:

Option Explicit
Sub 数组队列()
Dim I, J, arr1, arr2, arr3, m As Integer, n As Integer
m = 10  '第一列数
n = 10  '第二列数
arr1 = Range("a1:a" & m)
arr2 = Range("b1:b" & n)
Dim d As Object
Set d = CreateObject("scripting.dictionary")
For I = 1 To UBound(arr1, 1)
    For J = 1 To UBound(arr2, 1)
         d(arr1(I, 1) & arr2(J, 1)) = ""
    Next J
Next I
arr3 = d.Keys
Range("c1").Resize(d.Count) = Application.Transpose(arr3)
Dim zu As Integer
    zu = d.Count \ (2 * n)
Dim d1 As Object, k As Integer, h As Integer
Set d1 = CreateObject("scripting.dictionary")
h = 1

For I = 1 To d.Count
    On Error GoTo 100
    If I <= 2 * n * k + n + k Then
          d1(arr3((I - 1)) & "-" & arr3(I - 1 + n + 1)) = ""
          d.Remove arr3(I - 1)
          d.Remove arr3(I - 1 + n + 1)
          Debug.Print arr3((I - 1)) & "-" & arr3(I - 1 + n + 1)
    Else
        k = k + 1
        If k > zu Then
               Do While I + n <= d.Count
                    d1(arr3((I - 1)) & "-" & arr3(I - 1 + n + 1)) = ""
                    Debug.Print arr3((I - 1)) & "-" & arr3(I - 1 + n + 1)
                    I = I + 1
                Loop
               
                Exit For
               
        End If
        I = I + n
    End If
Next I
End
100:
   Dim ARR4, Z
   ARR4 = d.Keys
   Z = d.Count / 2
   For I = 1 To d.Count
        If I <= Z Then
            d1(ARR4(I - 1) & "-" & ARR4(I + Z - 1)) = ""
            Debug.Print ARR4(I - 1) & "-" & ARR4(I + Z - 1)
       Else
            Range("D1").Resize(d1.Count) = Application.Transpose(d1.Keys)
            End
        End If
   Next I
End Sub

1638009501(1).png

两两组合.zip

14.17 KB, 下载次数: 0

回复

使用道具 举报

 楼主| 发表于 2021-11-28 00:47 | 显示全部楼层
林木水 发表于 2021-11-27 18:38
老铁,我尽力了,一般最后几个对数,没有想到办法处理不出现重复的,但是 也不难,自己手动调一下就可以了 ...

非常感谢!但从前面几个数来看,A1始终对着A2,不满足条件,应该A1会对A2至少一次,最多只有两次
回复

使用道具 举报

发表于 2021-11-29 09:34 | 显示全部楼层
本来想也来做一个试试的,看了2楼的结果,我感觉也差不多啊,但楼主说不对,他说A1始终对着A2,就是这个地方看不懂,我看到前两个结果是相符的啊;
规则第三条无法理解,“他的对手至少出现一次,最多只能出现两次”,完全看不懂。楼主也没有举例说明什么样的情况不能再重复出现;
回复

使用道具 举报

 楼主| 发表于 2021-11-29 11:01 | 显示全部楼层
hfwufanhf2006 发表于 2021-11-29 09:34
本来想也来做一个试试的,看了2楼的结果,我感觉也差不多啊,但楼主说不对,他说A1始终对着A2,就是这个地 ...

比如说A1的对手,就只能是A2、A3、A4、A5、A6、A7、A8、A9、A10、B1、B2、B3、B4、B5、B6、B7、B8、B9、B10 (共19个,所以会有一个是重复的),就是第三条所说的:每一个人,他的对手至少出现一次,最多只能出现两次

比如:A1B1 vs A2B2,此时,A1、B1的对手是A2、B2
回复

使用道具 举报

发表于 2021-11-29 11:28 | 显示全部楼层
浪子神剑 发表于 2021-11-29 11:01
比如说A1的对手,就只能是A2、A3、A4、A5、A6、A7、A8、A9、A10、B1、B2、B3、B4、B5、B6、B7、B8、B9、B ...

还是看不懂,比如下面这类情况你就没说清楚:
A1B1 对 A2B2、A2B3、A2B4、A2B5...
如果强调 A1只能对 A2一次,那么是选 A2B2 还是 A2B3 或者是 A2B4,又或者是随机选一个,先碰到谁就选谁?
这才是关键点,因为 你说的 A1不能重复对应 A2,但 A2B2 与 A2B3 本就不是一个东西。

另外还是第三条规则你也没解释,指什么情况下允许2次,最好有实例,需要 AXBX 这样的组合实例才看的明白;
回复

使用道具 举报

 楼主| 发表于 2021-11-29 12:00 | 显示全部楼层
hfwufanhf2006 发表于 2021-11-29 11:28
还是看不懂,比如下面这类情况你就没说清楚:
A1B1 对 A2B2、A2B3、A2B4、A2B5...
如果强调 A1只能对 A ...

可能表达不太清楚,我重新组织下:
1. A的值从1-10,分别为A1-10
2. B也是从1-10,分别为B1-B10
3. A和B的任意组合有10 * 10 = 100种,即A1B1,A1B2...A10B10,每个人都有10种组合
4. 把上面的组合进行随机PK,
如:A1B2(搭档) VS A2B3(对手)...
解释:此时A1B2互为搭档,A2、B3为A1、B1的对手
5. 因为每人有10局,所以他的对手也就会有20个,举例:
A1B1 vs xxxx
A1B2 vs xxxx
A1B3 vs xxxx
A1B4 vs xxxx
A1B5 vs xxxx
A1B6 vs xxxx
A1B7 vs xxxx
A1B8 vs xxxx
A1B9 vs xxxx
A1B10 vs xxxx

因为总人数为20人,A1的对手有20个,但不能包括自己,所以只能是19人
即B有10人,A有9人,20-19=1,由此得出,必定是有且只会有一个重复的
具体xxxx的对手是谁,不一定



回复

使用道具 举报

发表于 2021-11-29 12:57 | 显示全部楼层
浪子神剑 发表于 2021-11-29 12:00
可能表达不太清楚,我重新组织下:
1. A的值从1-10,分别为A1-10
2. B也是从1-10,分别为B1-B10

感觉还是没看懂,也不好意思再问了。总要有个行动,就瞎写一个吧。你先看下截图,如果不对代码就别看了:


没传文件,主要是觉得没理解你的意思,只发个参考代码;

重点就是两个函数,尤其第二个函数def,是判断历史记录中不能有重复,我感觉关键点就在那个函数里中的逻辑对不对了,关键的地方我做了备注,你可以根据需要适当变化;

sub 按钮1_Click()
[d:d].Clear
Dim arr()
js = 1
For i = 1 To [a65000].End(3).Row
    For k = 1 To [b65000].End(3).Row
        ReDim Preserve arr(1 To js)
        arr(js) = Cells(i, 1) & Cells(k, 2)
        js = js + 1
    Next k
Next i
Dim brr()
js = 1
For i = 1 To UBound(arr)
    For k = i + 1 To UBound(arr)
        s1 = arr(i)
        s2 = arr(k)
        If js > 1 Then
           If Not def((s1), (s2), brr) Then
              If Not abc((s1), (s2)) Then
                 ReDim Preserve brr(js)
                 brr(js) = s1 & "-" & s2
                 js = js + 1
              End If
           End If
        Else
           ReDim Preserve brr(js)
           brr(js) = s1 & "-" & s2
           js = js + 1
        End If
    Next k
Next i
For i = 1 To UBound(brr)
    Cells(i, 4) = brr(i)
Next i
End Sub

Function abc(x1 As String, x2 As String) As Boolean    '此函数判断该组对手不能重复
xx1 = Mid(x1, 1, Len(x1) / 2)
xx2 = Mid(x1, Len(x1) / 2 + 1, Len(x1) / 2)
xx3 = Mid(x2, 1, Len(x2) / 2)
xx4 = Mid(x2, Len(x2) / 2 + 1, Len(x2) / 2)
abc = False
If (xx1 = xx3) Or (xx1 = xx4) Or (xx2 = xx3) Or (xx2 = xx4) Then
   abc = True
End If
End Function

Function def(x1 As String, x2 As String, x3) As Boolean  '此函数判断不能有历史重复,与上面函数有区别,上面的函数只判断当前对手,这个是检索历史记录中也不能有重复
xx1 = Mid(x1, 1, Len(x1) / 2)                           '分拆当前第一个记录为两个部分
xx2 = Mid(x1, Len(x1) / 2 + 1, Len(x1) / 2)
xx3 = Mid(x2, 1, Len(x2) / 2)                           '分拆当前第二个对手为两个部分
xx4 = Mid(x2, Len(x2) / 2 + 1, Len(x2) / 2)
js1 = 0
def = False
For i = 1 To UBound(x3)
    xx5 = Mid(x3(i), 1, InStr(x3(i), "-") - 1)                '读取历史记录中的第一个对手
    xx6 = Mid(x3(i), InStr(x3(i), "-") + 1, 100)           '读取历史记录中的第二个对手
    xx7 = Mid(xx5, 1, Len(xx5) / 2)                          '分拆历史记录第一个对手为两个部分
    xx8 = Mid(xx5, Len(xx5) / 2 + 1, Len(xx5) / 2)
    xx9 = Mid(xx6, 1, Len(xx6) / 2)                          '分拆历史记录第二个对手为两个部分
    xx10 = Mid(xx7, Len(xx6) / 2 + 1, Len(xx6) / 2)
    If (xx1 = xx7 Or xx2 = xx8) And (xx3 = xx9 Or xx4 = xx10) Then    '把当前记录与历史记录的两个对手分别做对比,不能有任何等同
       def = True
       Exit For
    End If
Next i
End Function


1.png
回复

使用道具 举报

 楼主| 发表于 2021-11-29 14:13 | 显示全部楼层
hfwufanhf2006 发表于 2021-11-29 12:57
感觉还是没看懂,也不好意思再问了。总要有个行动,就瞎写一个吧。你先看下截图,如果不对代码就别看了: ...

非常感谢!看了截图,a1b1,这一对重复了很多次,应该只有一次
回复

使用道具 举报

发表于 2021-11-29 14:34 | 显示全部楼层
浪子神剑 发表于 2021-11-29 14:13
非常感谢!看了截图,a1b1,这一对重复了很多次,应该只有一次

这个截图呢?主要是我无法领会你的意思,只能瞎碰运气。这次一共有90组,你先评估下总体数量对是否正确,如果差的太离谱,那肯定就错了,思路就差太远了。
1.png
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 16:33 , Processed in 0.656678 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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