[求助]组合求和问题请教彭希仁版主

jmhegr

彭老师您好！

        看了您的“数据组合求和”的代码我觉得非常实用：1 代码精简，运行速度快；2 组合结果分单元格放置于本工作表，用起来非常方便；3 组合结果的输出量可以根据需要调整，解决了许多无用的数据占用了大量空间的问题。总之我觉得非常好用！！

         在使用过程中又遇到了两个新问题，特向您请教，请您给以解决。

        情况是这样：在B列有M个数字，要求从中选出N个进行组合求和。我遇到的问题是：在您的代码中M和N都不能变化（M为18，N为9）。我的 要求是：1、M和N都为变量，即能够增加或减少，2 、N能够从某一个单元格（如C1)取值.这样使用起来更加方便快捷。想请您将原来的代码修改一下，能够满足我的要求。原来的代码如下：

Sub peng()
    arr = Cells(3, 2).Resize(18, 1)
    ReDim arr3(1 To 65536, 1 To 9) As Long
    ReDim arr2(1 To 10) As Long
    Call xi(i, j, arr, arr2, arr3, 0, 4190, 4150)
    Range(Cells(3, 9), Cells(65536, 17)) = arr3
End Sub

Sub xi(j, x, arr, arr2, arr3, jj, mx, mi)
If jj > 60000 Then Exit Sub
    If j = 10 Then Exit Sub
    If j > 1 And x > mi And x < mx Then
        jj = jj + 1
        For i = 1 To j
            arr3(jj, i) = arr2(i)
        Next i
        Exit Sub
    End If
    For i = 1 To 18
      If x + arr(i, 1) < mx Then
      arr2(j + 1) = arr(i, 1)
      xi j + 1, x + arr(i, 1), arr, arr2, arr3, jj, mx, mi
      End If
    Next i
End Sub

                 谢谢您了！！

彭希仁

http://club.excelhome.net/viewthread.php?tid=278319&replyID=&skin=0

A列为M

B1为N

想怎么样都可以,不过组合太多会死机哦,所以使用时要小心.

jmhegr

谢谢彭老师的指点，我去那里认真的看了，并且也下载进行了试用，很好。

    但是在那段代码中，上述代码中的一些功能没有了。即：一是第4句（Call xi(i, j, arr, arr2, arr3, 0, 4190, 4150)求和的限制功能没有了；二是第8句（If jj > 60000 Then Exit Sub）限制输出数量的功能没有了，三是不能将组合数据分单元格放在本工作表中。

    不知您能否在上述代码的基础上再增加“排列组合之最优算法”中的功能（即M和N都为变量且N能够从某一个单元格（如C1)取值）。真是太难为您了！如果太麻烦，那也就算了。

        谢谢您！！

彭希仁

Public jj As Long, mx, mi, arr, arr3, n As Long

Sub peng()
    arr = Cells(1, 1).Resize([a65536].End(xlUp).Row, 1)                       'm
    n = [b1]        'n
    jj = 0
    mx = 40
    mi = 10
    If n < 1 Then Exit Sub
    ReDim arr3(1 To 65536, 1 To n)
    ReDim arr2(1 To n + 1) As Long
    Call xi(i, j, arr2)
   Cells(1, 5).Resize(65536, n) = arr3
End Sub

Sub xi(j, x, arr2)
    If jj > 60000 Then Exit Sub
    If j = n + 1 Then Exit Sub
    If j > 1 And x > mi And x < mx Then
        jj = jj + 1
        For i = 1 To j
            arr3(jj, i) = arr2(i)
        Next i
        Exit Sub
    End If
    For i = 1 To UBound(arr)
        If x + arr(i, 1) < mx Then
            arr2(j + 1) = arr(i, 1)
            xi j + 1, x + arr(i, 1), arr2
        End If
    Next i
End Sub

jmhegr

谢谢彭老师的代码！

    我认真的试用了，可是没有组合的数据出现。运行代码后，只是看到状态栏提示：填充单元格，之后什么也没有了。不知我是否理解错了您的代码，现将试用的表格上传（见附件），请您检查。

    谢谢您！！

5R8J0NxL.rar (7.51 KB, 下载次数: 25)

2008-7-7 10:21 上传

点击文件名下载附件
[求助]组合求和问题请教彭希仁版主

168216130a

学习

彭希仁

之所以没有结果,那是因为最大值和最小值我随便设的值,你要重新设置一下.

Public jj As Long, mx, mi, arr, arr3, n As Long

Sub peng()
    arr = Cells(1, 1).Resize([a65536].End(xlUp).Row, 1)                       'm
    n = [b1]        'n
    jj = 0
    mx = 4190            '最大值
    mi = 4150            ,最小值
    If n < 1 Then Exit Sub
    ReDim arr3(1 To 65536, 1 To n)
    ReDim arr2(1 To n + 1) As Long
    Call xi(i, j, arr2)
   Cells(1, 5).Resize(65536, n) = arr3
End Sub

Sub xi(j, x, arr2)
    If jj > 60000 Then Exit Sub
    If j = n + 1 Then Exit Sub
    If j > 1 And x > mi And x < mx Then
        jj = jj + 1
        For i = 1 To j
            arr3(jj, i) = arr2(i)
        Next i
        Exit Sub
    End If
    For i = 1 To UBound(arr)
        If x + arr(i, 1) < mx Then
            arr2(j + 1) = arr(i, 1)
            xi j + 1, x + arr(i, 1), arr2
        End If
    Next i
End Sub

jmhegr

谢谢彭老师的辛勤劳动和耐心指教！！

    我已将您的代码下载进行了认真的学习和试用，这段代码真的很精彩。它的功能能否可以这样归纳：从M个数字中取N个进行有重排列（并非无重排列）、并对每组排列数字进行求和（“和”值在指定的范围内），同时将符合“和”值要求的各组排列数字按照指定的数量存放于本工作表。

    彭老师，我还有一个要求：请您将“有重排列”改为“无重组合”，就像“排列组合之最优算法”那样计算，其他功能不变。

   谢谢您！！

彭希仁

Public jj As Long, mx, mi, arr, arr3, n As Long

Sub peng()
    arr = Cells(1, 1).Resize([a65536].End(xlUp).Row, 1)                       'm
    n = [b1]        'n
    jj = 0
    mx = 4190            '最大值
    mi = 4150            ,最小值
    If n < 1 Then Exit Sub
    ReDim arr3(1 To 65536, 1 To n)
    ReDim arr2(1 To n + 1) As Long
    Call xi(i, j, arr2)
   Cells(1, 5).Resize(65536, n) = arr3
End Sub

Sub xi(j, x, arr2)
    If jj > 60000 Then Exit Sub
    If j = n + 1 Then Exit Sub
    If j > 1 And x > mi And x < mx Then
        jj = jj + 1
        For i = 1 To j
            arr3(jj, i) = arr2(i)
        Next i
        Exit Sub
    End If
    For i = j+1 To UBound(arr)
        If x + arr(i, 1) < mx Then
            arr2(j + 1) = arr(i, 1)
            xi j + 1, x + arr(i, 1), arr2
        End If
    Next i
End Sub

无重的

jmhegr

彭老师您好！

我将您的代码下载后进行了反复的试用，还是产生重复数字（见附件），不知是什么原因？请您再看一下。

   谢谢您！！

LoQX3FH5.rar (14.05 KB, 下载次数: 18)

2008-7-8 00:03 上传

点击文件名下载附件
[求助]组合求和问题请教彭希仁版主