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

彭希仁

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(1, j,x, arr2)
   Cells(1, 5).Resize(65536, n) = arr3
End Sub

Sub xi(i,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
if i+1>ubound(arr) then exit sub
        If x + arr(i, 1) < mx Then
            arr2(j + 1) = arr(i, 1)
            xi i+1,j, x, arr2
        End If

        If x + arr(i, 1) < mx Then
            arr2(j + 1) = arr(i, 1)
            xi i+1,j + 1, x + arr(i, 1), arr2
        End If
End Sub

改了改,没有试不知是否有效

jmhegr

谢谢彭老师，您辛苦了！

您修改后的代码我试用了一下，结果是重复的问题没有了，比较理想。

但是又发现了一个新问题：即组合结果不完整，丢掉了一部分数据。在同一条件下我用您的“排列组合之最优算法”和这次修改后的代码进行组合计算，计算结果后者比前者少了200多组数据，不知是什么原因？现将计算结果发来给您看看（见附件）。

我想，如果能够将“排列组合之最优算法”和您这次的“条件组合求和”代码结合在一块使用是最理想的了！

谢谢您！

d2Yr7dzL.rar (6.74 KB, 下载次数: 8)

2008-7-8 14:24 上传

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

彭希仁

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(1, j,x, arr2)
   Cells(1, 5).Resize(65536, n) = arr3
End Sub

Sub xi(i,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
if i+1>ubound(arr) then exit sub
        If x + arr(i, 1) < mx Then
            arr2(j + 1) = arr(i, 1)
            xi i+1,j, x, arr2
        End If

        If x + arr(i, 1) < mx Then
            arr2(j + 1) = arr(i, 1)
            xi i+1,j + 1, x + arr(i, 1), arr2
        End If
End Sub

jmhegr

谢谢彭老师！

我运行上述代码时提示：运行时错误‘28’  溢出堆栈空间

然后光标停在“宏XI”的第12句：
xi i + 1, j, x, arr2 

不知什么原因？

彭希仁

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(1, j, x, arr2)
    Cells(1, 5).Resize(65536, n) = arr3
End Sub

Sub xi(ii, 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
    If ii + 1 > UBound(arr) Then Exit Sub
   
   
    If x + arr(ii, 1) < mx Then
        arr2(j + 1) = arr(ii, 1)
        xi ii + 1, j, x, arr2
    End If
    If x + arr(ii, 1) < mx Then
        arr2(j + 1) = arr(ii, 1)
        xi ii + 1, j + 1, x + arr(ii, 1), arr2
    End If
End Sub

不好意思,我之过也,没有试一下就发给你了,中间变量用重了,所以导致了这个问题,已解决

[此贴子已经被作者于2008-7-8 17:50:45编辑过]

jmhegr

谢谢彭老师，您辛苦了！

您的代码我认真的试用了，“重复”和“出错提示”都已解决!

我真的非常喜欢您这段代码，因为它的运行效率很高，一次运行可完成几方面的工作。

但是在运行中还是存在丢掉数据的问题，现将丢掉数据的一个具体例子给您发来（见附件），请您看看有没有办法解决。真是麻烦您了。如果太难的话就算了。

                       我只能说谢谢您！！

j73tfLGU.rar (12.36 KB, 下载次数: 46)

2008-7-8 22:05 上传

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

彭希仁

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 = 49      '最大值
    mi = 30     '最小值
    If n < 1 Then Exit Sub
    ReDim arr3(1 To 65536, 1 To n)
    ReDim arr2(1 To n + 1) As Long
    Call xi(1, j, x, arr2)
    Cells(1, 12).Resize(65536, n) = arr3
    宏合计
End Sub

Sub xi(ii, 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
    End If
    If ii > UBound(arr) Then Exit Sub
   
   
    If x + arr(ii, 1) < mx Then
        xi ii + 1, j, x, arr2
    End If
    If x + arr(ii, 1) < mx Then
        arr2(j + 1) = arr(ii, 1)
        xi ii + 1, j + 1, x + arr(ii, 1), arr2
    End If
End Sub

kzb

Sub xi(ii, 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
    End If
    If ii > UBound(arr) Then Exit Sub
   
   
    If x + arr(ii, 1) < mx Then
        xi ii + 1, j, x, arr2
    End If
    If x + arr(ii, 1) < mx Then
        arr2(j + 1) = arr(ii, 1)
        xi ii + 1, j + 1, x + arr(ii, 1), arr2
    End If
End Sub

此段程序能详细讲解注释一下吗？谢谢！

jmhegr

谢谢彭老师不厌其烦的指教！

我正在试用学习

ljl008

找了很久，下了学习！谢谢各位！