设为首页收藏本站
简字体切换切换到宽版

ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步，快速开始

快捷登录

搜索
ExcelHome技术论坛»论坛 › Excel 技术交流与问答 › Excel VBA程序开发 › 求五个数中取2个数和取0个数的所有组合
EH技术汇-专业的职场技能充电站 妙哉！函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器，一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理，一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
12下一页
返回列表 发新帖
查看: 3684|回复: 18

[求助] 求五个数中取2个数和取0个数的所有组合

[复制链接]
lljd808

TA的精华主题

TA的得分主题
发表于 2018-9-15 17:44 | 显示全部楼层 |阅读模式
[广告] ★会Excel,就能做支持PC、手机、Web、App、Windows、安卓、IOS、Linux信息一体化的各种管理系统 ★
求：由E列的每行五个数字，推出AP及以后列的数据。               

               
AP列数字是由e2里的五个数字取2个的所有组合。               
               
AQ列数字是由e3里的五个数字取2个的所有组合。               
               
Ar列及以后，依次类推        

求大侠帮忙，谢谢！！
大侠, AP列数字, 五个, 个数

求五个数中取2个数和取0个数的所有组合.rar

9.09 KB, 下载次数: 9
回复

举报

liulang0808

TA的精华主题

TA的得分主题
发表于 2018-9-15 18:30 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册★
就是split+双层for循环即可
这样的案例，论坛里真不少
回复

举报

lljd808

TA的精华主题

TA的得分主题
 楼主| 发表于 2018-9-15 19:13 | 显示全部楼层
[广告] ★Excel Home云课堂 - 专业的职场技能充电站★         ★Excel三大利器★        ★ 笨办法学VBA全系列★
liulang0808 发表于 2018-9-15 18:30
就是split+双层for循环即可
这样的案例，论坛里真不少

这对我来说就难了，我的基础太低，这个问题困扰了我很长时间，
麻烦能在附件里给做一下好吗，谢谢！！
回复

举报

liulang0808

TA的精华主题

TA的得分主题
发表于 2018-9-15 20:29 | 显示全部楼层
[广告] ★ ReportLite:表哥表姐早下班神器，专治各种报表不服，拒绝无意义的重复劳动 ★
  1. Sub 按钮1_Click()
  2.     Application.ScreenUpdating = False
  3.     Set d = CreateObject("scripting.dictionary")
  4.     arr = Range([e1], Cells(Rows.Count, "e").End(3))
  5.     For j = 2 To UBound(arr)
  6.         If Len(arr(j, 1)) > 10 Then
  7.             brr = Split(arr(j, 1), " ")
  8.             x = 2
  9.             d.RemoveAll
  10.             For i = 0 To UBound(brr)
  11.                 d(brr(i) * 1) = i
  12.                 For l = 0 To UBound(brr)
  13.                     If i <> l Then
  14.                         Cells(x, j + 40) = Format(brr(i), "00") & " " & Format(brr(l), "00")
  15.                         x = x + 1
  16.                     End If
  17.                 Next l
  18.             Next i
  19.             y = 0
  20.             For i = 1 To 10
  21.                 If Not d.exists(i) Then
  22.                     brr(y) = i
  23.                     y = y + 1
  24.                 End If
  25.             Next i
  26.             For i = 0 To UBound(brr)
  27.                 d(brr(i)) = i
  28.                 For l = 0 To UBound(brr)
  29.                     If i <> l Then
  30.                         Cells(x, j + 40) = Format(brr(i), "00") & " " & Format(brr(l), "00")
  31.                         x = x + 1
  32.                     End If
  33.                 Next l
  34.             Next i
  35.         End If
  36.     Next j
  37.     Application.ScreenUpdating = True
  38. End Sub
复制代码

评分

1

查看全部评分

回复

举报

liulang0808

TA的精华主题

TA的得分主题
发表于 2018-9-15 20:29 | 显示全部楼层
[广告] ★会Excel,就能做支持PC、手机、Web、App、Windows、安卓、IOS、Linux信息一体化的各种管理系统 ★
附件内容供参考。。。。。。

求五个数中取2个数和取0个数的所有组合.zip

25 KB, 下载次数: 15

评分

1

查看全部评分

回复

举报

lljd808

TA的精华主题

TA的得分主题
 楼主| 发表于 2018-9-15 20:48 | 显示全部楼层
[广告] ★会Excel,就能做支持PC、手机、Web、App、Windows、安卓、IOS、Linux信息一体化的各种管理系统 ★
liulang0808 发表于 2018-9-15 20:29
附件内容供参考。。。。。。

这个效果是对的，就是因为数据转换量大，速度有点慢，我不用那么多列，要调哪里？先谢谢，请指点！！
回复

举报

liulang0808

TA的精华主题

TA的得分主题
发表于 2018-9-15 20:50 | 显示全部楼层
[广告] ★会Excel,就能做支持PC、手机、Web、App、Windows、安卓、IOS、Linux信息一体化的各种管理系统 ★
lljd808 发表于 2018-9-15 20:48
这个效果是对的，就是因为数据转换量大，速度有点慢，我不用那么多列，要调哪里？先谢谢，请指点！！

如果数据多，就改成数组处理吧
回复

举报

lljd808

TA的精华主题

TA的得分主题
 楼主| 发表于 2018-9-15 20:52 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助★
本帖最后由 lljd808 于 2018-9-15 21:04 编辑
liulang0808 发表于 2018-9-15 20:29

好的，要减少转换的组数，是改“  Cells(x, j + 40) ”这里吗，我试了下，不对，只是行数减少了。
先谢谢！
回复

举报

liulang0808

TA的精华主题

TA的得分主题
发表于 2018-9-15 20:54 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助★
lljd808 发表于 2018-9-15 20:52
好的，要减少转换的组数，是改“  Cells(x, j + 40) ”这里吗
先谢谢！
  1. Sub 按钮1_Click()
  2.     Application.ScreenUpdating = False
  3.     Dim crr(1 To 40, 1 To 1)
  4.     Set d = CreateObject("scripting.dictionary")
  5.     arr = Range([e1], Cells(Rows.Count, "e").End(3))
  6.     For j = 2 To UBound(arr)
  7.         If Len(arr(j, 1)) > 10 Then
  8.             brr = Split(arr(j, 1), " ")
  9.             x = 1
  10.             Erase crr
  11.             d.RemoveAll
  12.             For i = 0 To UBound(brr)
  13.                 d(brr(i) * 1) = i
  14.                 For l = 0 To UBound(brr)
  15.                     If i <> l Then
  16.                         crr(x, 1) = Format(brr(i), "00") & " " & Format(brr(l), "00")
  17.                         x = x + 1
  18.                     End If
  19.                 Next l
  20.             Next i
  21.             y = 0
  22.             For i = 1 To 10
  23.                 If Not d.exists(i) Then
  24.                     brr(y) = i
  25.                     y = y + 1
  26.                 End If
  27.             Next i
  28.             For i = 0 To UBound(brr)
  29.                 d(brr(i)) = i
  30.                 For l = 0 To UBound(brr)
  31.                     If i <> l Then
  32.                         crr(x, 1) = Format(brr(i), "00") & " " & Format(brr(l), "00")
  33.                         x = x + 1
  34.                     End If
  35.                 Next l
  36.             Next i
  37.             Cells(2, j + 40).Resize(40) = crr
  38.         End If
  39.     Next j
  40.     Application.ScreenUpdating = True
  41. End Sub
复制代码

评分

1

查看全部评分

回复

举报

liulang0808

TA的精华主题

TA的得分主题
发表于 2018-9-15 20:57 | 显示全部楼层
[广告] ★会Excel,就能做支持PC、手机、Web、App、Windows、安卓、IOS、Linux信息一体化的各种管理系统 ★
lljd808 发表于 2018-9-15 20:52
好的，要减少转换的组数，是改“  Cells(x, j + 40) ”这里吗
先谢谢！
  1. Sub 按钮1_Click()
  2.     Application.ScreenUpdating = False
  3.     Dim crr(1 To 40, 1 To 1)
  4.     Set d = CreateObject("scripting.dictionary")
  5.     arr = Range([e1], Cells(Rows.Count, "e").End(3))
  6.     For j = 2 To UBound(arr)
  7.         If Len(arr(j, 1)) > 10 Then
  8.             brr = Split(arr(j, 1), " ")
  9.             x = 1
  10.             Erase crr
  11.             d.RemoveAll
  12.             For i = 0 To UBound(brr)
  13.                 d(brr(i) * 1) = i
  14.                 For l = 0 To UBound(brr)
  15.                     If i <> l Then
  16.                         crr(x, 1) = Format(brr(i), "00") & " " & Format(brr(l), "00")
  17.                         x = x + 1
  18.                     End If
  19.                 Next l
  20.             Next i
  21.             y = 0
  22.             For i = 1 To 10
  23.                 If Not d.exists(i) Then
  24.                     brr(y) = i
  25.                     y = y + 1
  26.                 End If
  27.             Next i
  28.             For i = 0 To UBound(brr)
  29.                 d(brr(i)) = i
  30.                 For l = 0 To UBound(brr)
  31.                     If i <> l Then
  32.                         crr(x, 1) = Format(brr(i), "00") & " " & Format(brr(l), "00")
  33.                         x = x + 1
  34.                     End If
  35.                 Next l
  36.             Next i
  37.             Cells(2, j + 40).Resize(40) = crr
  38.         End If
  39.     Next j
  40.     Application.ScreenUpdating = True
  41. End Sub
复制代码

评分

2

查看全部评分

回复

举报

下一页 »
12下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2025-1-15 14:08 , Processed in 0.028971 second(s), 19 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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