ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

[求助] 求助大神棘手难题:数列组合运算,找出数列中运算结果小于误差的所有组合。

[复制链接]

TA的精华主题

TA的得分主题

发表于 2020-2-29 20:42 | 显示全部楼层 |阅读模式
求助各路大神老师,需要计算一个数列中,数值组合运算后结果小于误差的值(见下图)
VBA小白一个,肯请各位帮忙,先谢谢了!

数列组合运算.jpg

数列组合计算.rar

8.46 KB, 下载次数: 22

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-3-1 11:36 | 显示全部楼层
麻烦各位老师帮忙给个代码啊,哪怕就给出出组合1和组合2的也行啊,急用,多谢了!

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-3-2 11:45 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
麻烦各位给个建议啊

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-3-3 16:06 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2020-3-3 16:59 | 显示全部楼层
组合2示例,其他如法炮制即可

  1. Sub test2()
  2.     Dim arr, brr, crr, limit, m&, n&, sum
  3.     arr = [a1].Resize([a2].End(4).Row, 2)
  4.     limit = arr(2, 2)
  5.     ReDim brr(1 To (UBound(arr) - 4) ^ 3, 1 To 2)
  6.     For i = 5 To UBound(arr)
  7.         For j = i To UBound(arr)
  8.             For k = i To UBound(arr)
  9.                 If i <> k And j <> k Then
  10.                     sum = arr(i, 2) + arr(j, 2) - arr(k, 2)
  11.                     If sum >= 0 Then
  12.                         n = n + 1
  13.                         brr(n, 1) = arr(i, 1) & "+" & arr(j, 1) & "-" & arr(k, 1)
  14.                         brr(n, 2) = sum
  15.                     End If
  16.                 End If
  17.             Next k, j, i
  18.             ReDim crr(1 To n ^ 2, 1 To 2)
  19.             For i = 1 To n - 1
  20.                 For j = i + 1 To n
  21.                     If Abs(brr(j, 2) - brr(i, 2)) <= limit Then
  22.                         m = m + 1
  23.                         crr(m, 1) = brr(i, 1)
  24.                         crr(m, 2) = brr(i, 2)
  25.                         m = m + 1
  26.                         crr(m, 1) = brr(j, 1)
  27.                         crr(m, 2) = brr(j, 2)
  28.                     End If
  29.                 Next j, i
  30.                 [e5].Resize(m, 2) = crr
  31.                 MsgBox "OK"
  32.             End Sub
复制代码

评分

2

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-3-4 14:33 | 显示全部楼层
northwolves 发表于 2020-3-3 16:59
组合2示例,其他如法炮制即可

居然能得到northwolves老师的回复,万分感谢!
我在运行的过程中发现个小问题: 运行完排序后发现部分组合有重复(图1), 但还有部分组合没有列出,不知该如何调整.
麻烦您了!

1.jpg
2.jpg

TA的精华主题

TA的得分主题

发表于 2020-3-4 21:06 | 显示全部楼层
组合1
9个数,可重复取2个 C(9+2-1,2)=45种
其中9种重复,余8个数,再取1个,8种,排列后9*8=72种
     36种不重复,余7个数,再取1个,7种,排列后36*7=252种

总计324种。

其他类推

TA的精华主题

TA的得分主题

发表于 2020-3-5 12:41 | 显示全部楼层
'2-5组合全输出,自己挑选,,,

Option Explicit

Sub test()
  Dim arr, brr, i As Long, j As Long, n As Long, p As Long
  Dim m As Long, k As Long, kk As Long
  brr = Range("a5:b" & [a5].End(xlDown).Row)
  ReDim arr(1 To UBound(brr, 1) * 2, 1 To 2)
  For i = 1 To UBound(brr, 1)
    arr(i, 1) = "+" & brr(i, 1): arr(i, 2) = brr(i, 2)
    arr(UBound(brr, 1) + i, 1) = "-" & brr(i, 1)
    arr(UBound(brr, 1) + i, 2) = -brr(i, 2)
  Next
  [a16].Resize(UBound(arr, 1), 2) = arr
  ReDim brr(1 To 2 ^ UBound(arr, 1) + 1, 1 To 3)
  ReDim crr(1 To 2 ^ UBound(arr, 1), 1 To 3)
  brr(2, 1) = arr(1, 1): brr(2, 2) = arr(1, 2): brr(2, 3) = 1
  n = 2
  For i = 2 To UBound(arr, 1)
    For j = n + 1 To 2 * n
      brr(j, 1) = brr(j - n, 1) & arr(i, 1)
      brr(j, 2) = brr(j - n, 2) + arr(i, 2)
      brr(j, 3) = brr(j - n, 3) + 1
    Next
    n = n * 2
  Next
  ReDim arr(1 To 10 ^ 6, 1 To 3) As String
  Call qsort(brr, 2, UBound(brr, 1) - 1, 1, 3, 3)
  p = 2
  For i = 2 To UBound(brr, 1) - 1
    If brr(i, 3) <> brr(i + 1, 3) Then
      Call qsort(brr, p, i, 1, 3, 2)
      If brr(i, 3) >= 2 And brr(i, 3) <= 5 Then '取2-5组合
        For j = p To i - 1
          For k = j + 1 To i
            If brr(k, 2) - brr(j, 2) > 0.9 Then
              If k - j > 2 Then
                For kk = j To k - 1
                  m = m + 1
                  arr(m, 1) = brr(kk, 1)
                  arr(m, 2) = brr(kk, 2)
                  arr(m, 3) = brr(kk, 3)
                Next
                m = m + 1
              End If
              Exit For
            End If
          Next
        Next
      End If
      p = i + 1
    End If
  Next
  Debug.Print m
  [m1].Resize(, 3) = Split("组,结果,组合数", ",")
  With [m2]
    .Resize(Rows.Count - 1, 3).ClearContents
    If m > 0 Then .Resize(m, 3) = arr
  End With
End Sub

Sub qsort(arr, first, last, left, right, key)
  Dim i As Long, j As Long, k As Long, x, t
  i = first: j = last: x = arr((first + last) / 2, key)
  While i <= j
    While arr(i, key) < x: i = i + 1: Wend
    While x < arr(j, key): j = j - 1: Wend
    If i <= j Then
      For k = left To right
        t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
      Next
      i = i + 1: j = j - 1
    End If
  Wend
  If first < j Then qsort arr, first, j, left, right, key
  If i < last Then qsort arr, i, last, left, right, key
End Sub

评分

4

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-3-5 19:12 | 显示全部楼层
一把小刀闯天下 发表于 2020-3-5 12:41
'2-5组合全输出,自己挑选,,,

Option Explicit

非常感谢您的回复。
运行了一下,发现有个小问题,以2个数组合为例,缺少了一些组合,多了一些组合。以2个数A+B的X1的组合为例,运行后排序见截图。上半部分缺少了x1+x1, x1+x6, x1+x7, x1+x8, x1+x9.  在两个数组合中减法不需要运算(见截图下半部分)。不知代码该如何调整?
再次感谢!



123.jpg

TA的精华主题

TA的得分主题

发表于 2020-3-5 19:33 | 显示全部楼层
是的,会多出组合,确实没有考虑去重

缺少应该不会的,按全组合生成,只是选了2-5组合符合条件输出而已,刚才看了一下是有很多重复的

运行后你不要排序,因为它们是以组存在的,每个空行之间都为一组,,,

评分

3

查看全部评分

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

本版积分规则

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

GMT+8, 2024-3-29 13:12 , Processed in 0.248301 second(s), 11 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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