史上最酷的Excel VBA 组合算法 代码

香川群子

longe1013 发表于 2016-6-16 12:54
香川老师，我刚发了个求助帖但是审核中求助不了，能不能帮我看看怎么用您这个方式实现这个呢？

你的要求并没有说清楚。别人看不懂的。

需要具体举例说明。

longe1013

香川群子 发表于 2016-6-16 15:47
你的要求并没有说清楚。别人看不懂的。

需要具体举例说明。

本帖最后由 longe1013 于 2016-6-16 16:00 编辑

数据一	数据二	数据三	数据四	组合条件	结果
1	a	A	I	1:2
2	b	B	II	1:3:4
3	c	C	III	1:2:3:4
4	d	D	IV
5	e	E	V
6	f	F	VI

如上，我希望按照组合的条件要求对前面四列的数据组合拼接在一起，1:2表示用第一列和第二列进行组合，如何把这三种组合的条件的结果计算出来并把结果放在【结果】列。求大师们帮忙看下，附件已上。举例条件1:2
1a
1b
1c
...
6f
举例条件1:2:3
1aA
1aB
1aC
...
6fF
同理，我需要把这三种的组合条件汇总在结果列，如何实现？
Sub 自由组合()
    num(0) = Sheet1.Cells(1, Columns.Count).End(1).Column
    If Sheet1.Cells(1, num(0)) <> "组合" Or Sheet1.Cells(Rows.Count, num(0)).End(3).Row < 2 Then
    MsgBox "请设定组合序列"
    Exit Sub
    End If
    For i = 2 To Sheet1.Cells(Rows.Count, num(0)).End(3).Row
        myarr = Split(Sheet1.Cells(i, num(0)), ":")
        num(1) = LBound(myarr)
        If num(1) >= 2 Then
            For j = 2 To Sheet1.Cells(1, myarr(0)).End(4).Row
                For k = 2 To Sheet1.Cells(1, myarr(1)).End(4).Row
                不知道怎么写下去了。。。
                Next
            Next
        End If
    Next
End Sub

上面我想写的，但是因为条件的组合列数不确定，所以不知道怎么写下去了，万谢！

组合求助.rar (6.61 KB, 下载次数: 14)

2016-6-16 16:04 上传

点击文件名下载附件

人生如游戏

必须支持，虽然自己不懂，谢谢分享！！

futurevision

我是菜鸟，请问怎么把不同组的VBA数据放到一张表格里，请看附件！

futurevision

这里是附件，请帮我看看！

futurevision

这里是附件，请帮我看看！

futurevision

香川群子 发表于 2016-6-16 15:47
你的要求并没有说清楚。别人看不懂的。

需要具体举例说明。

大师，我是菜鸟，帮帮我吧！最近因为工作需要才开始研究VBA的。
我们的产品有L,M,P......很多种材质的，我想先用VBA组合代码 9选3 把描述每种材质的词放在一起，组合成84个核心词（详见表格中的“组合总表”），那么问题来了，我们的产品同时又有很多种不同的叫法，于是我想到让数组当中的每个元素与不同的叫法都结合一次，变成N个扩展关键词。

我现在遇到的问题是：
1.用VBA做组合的时候，除开列出组合数组，怎么通过修改VBA代码让每个组合元素单独列3列出来。
2.我的文件里有很多sheet,晚点还可能要加更多进去，有没有简便的方法，不用写函数公式进去，而通过VBA代码来简化手动工作？

工作需要，急等，
求帮忙，跪谢！

7473v6575ba

好代码，收藏！
如果循环之处可以注释，就省下了按F8。。N次了。

15162039800

请教个问题24选9包含24选6每一组的最少组数

15162039800

比如你写的这个代码是11选5组合成11选8的最少组数:Sub kagawa()
    Dim i&, j&, k&, h&, m&, n&, Ac&, r&, s$, t, cnt&
    tms = Timer
   
    m = 11: n = 8: Ac8 = Application.Combin(m, n)
    ReDim Combin8&(1 To Ac8, 1 To m)
    Call GetCombinArr(Combin8, m, n)
   
    Sheet1.Activate
    m = Sheet1.[a1].End(4).Row
    arr = Sheet1.[c1].Resize(m, 5)
'    Sheet2.Activate
    ReDim brr&(2 To m, 1 To 5)
    For i = 2 To m
        For j = 1 To 5
            brr(i, j) = arr(i, j)
        Next
    Next
   
    ReDim crr(1 To Ac8, 1 To m)
    For k = 1 To Ac8
        cnt = 0
        For i = 2 To m
            r = 0
            For j = 1 To 5
                r = r + Combin8(k, brr(i, j))
            Next
            If r = 5 Then crr(k, i) = i: cnt = cnt + 1
        Next
        crr(k, 1) = cnt
    Next
    With Sheet2
        .[a1].CurrentRegion.AutoFilter
        .[a1].CurrentRegion.Offset(1, 9) = ""
        .[k2].Resize(Ac8, m) = crr
        .Cells(1, 10) = "result"
        .Cells(1, 11) = "cnt"
        For i = 2 To m
            .Cells(1, i + 10) = "s" & i
        Next
    End With
   
    ReDim drr(1 To Ac8, 0 To 1)
    For i = 1 To Ac8
        drr(i, 1) = 1
    Next
   
    ReDim frr(2 To m) As Boolean
    Randomize
    h = m - 1
    k = 0
    Do
        cnt = 1
        For i = 1 To Ac8
            If drr(i, 1) > 0 Then
                r = 0
                For j = 2 To m
                    If Not frr(j) Then If crr(i, j) Then r = r + 1
                Next
                If r Then drr(i, 1) = r Else drr(i, 1) = ""
                If r = cnt Then s = s & "," & i Else If r > cnt Then cnt = r: s = i
            End If
        Next
        
        t = Split(s, ",")
        r = t(Int(Rnd * (UBound(t) + 1)))
        
        cnt = 0
        For j = 2 To m
            If Not frr(j) Then If crr(r, j) Then frr(j) = True: cnt = cnt + 1
        Next
        drr(r, 0) = cnt
        drr(r, 1) = ""
        h = h - cnt
        k = k + 1
    Loop While h
    With Sheet2
        .[j2].Resize(Ac8) = drr
        .[a1].AutoFilter Field:=10, Criteria1:="<>"
        .[i1].Resize(Ac8, 3).SpecialCells(xlCellTypeVisible).Copy
    End With
'    Sheet1.Activate
    Sheet1.[j1].CurrentRegion = ""
    Sheet1.[j1].PasteSpecial Paste:=xlPasteValues
   
    MsgBox Format(Timer - tms, "0.000s ") & k
End Sub
Sub GetCombinArr(arr&(), m&, n&)
    Dim i&, j&, l&
    ReDim a&(1 To n)
    a(1) = 0: a(n) = m: j = 1
    For i = 1 To Application.Combin(m, n)
        If a(n) = m Then
            a(j) = a(j) + 1
            If a(j) < m - n + j Then
                For j = j To n - 1
                    a(j + 1) = a(j) + 1
                Next
            End If
            j = j - 1
        Else
            a(n) = a(n) + 1
        End If
        For l = 1 To n
            arr(i, a(l)) = 1
        Next
    Next
End Sub如果做成24选6组合成24选9的最少组合应该怎么做