Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 3761|回复: 15

[已解决]一个Vba的超级难题求解…恳求大神出手...!

[复制链接]
发表于 2017-5-9 20:15 | 显示全部楼层 |阅读模式
本帖最后由 On_fire 于 2017-5-10 13:50 编辑

这难题是一种 [线性关系 ] 的统计

原始资料 (1, 4列, 比如:有A, B, C, D, 4个原素):

1.组合就是大写项生成小写项 ( 截图-2 )
2.对小写项进行分类汇总(计数)


分类汇总: 统计部分
统计1,条件(原素)及结果(原素), 必需顺序
统计2,条件(原素)及结果(原素), 没有顺序要求

最佳答案
2017-5-18 16:14
  1. Sub aaa()
  2. Dim arr, s$, s1$, i&, j&, k&, d As Object, brr, crr, a&, b&, c&, n&, r&, r1&, mx$, rx&, tmp$
  3. Set d = CreateObject("scripting.dictionary")
  4. arr = Range("a4:g" & [a65536].End(3).Row)
  5. For i = 1 To UBound(arr)
  6.   For j = 1 To 3
  7.     For k = j To 4
  8.       mx = arr(i, j)
  9.       If mx > arr(i, k) Then
  10.         mx = arr(i, k)
  11.         rx = k
  12.       End If
  13.     Next k
  14.     If mx <> arr(i, j) Then
  15.       tmp = arr(i, j)
  16.       arr(i, j) = arr(i, rx)
  17.       arr(i, rx) = tmp
  18.     End If
  19.   Next j
  20. Next i
  21. n = InputBox("Please input ...")
  22. [j:y].ClearContents
  23. For k = 1 To 2
  24.   ReDim brr(1 To Application.Combin(4, n) * UBound(arr), 1 To n + 4)
  25.   If k = 2 Then
  26.     For r1 = 2 To UBound(arr)
  27.       If arr(r1, 6) > arr(r1, 7) Then
  28.         tmp = arr(r1, 6)
  29.         arr(r1, 6) = arr(r1, 7)
  30.         arr(r1, 7) = tmp
  31.       End If
  32.     Next r1
  33.   End If
  34.   For i = 1 To UBound(arr)
  35.     For a = 1 To 5 - n
  36.       For b = a + 1 To 6 - n
  37.         For c = b + 1 To 7 - n
  38.           s = arr(i, a) & arr(i, b) & arr(i, 6) & arr(i, 7)
  39.           If n = 3 Then s = s & arr(i, c)
  40.           If Not d.exists(s) Then
  41.             r = r + 1
  42.             d(s) = r
  43.             brr(r, 1) = arr(i, a)
  44.             brr(r, 2) = arr(i, b)
  45.             If n = 3 Then brr(r, 3) = arr(i, c)
  46.             brr(r, n + 2) = arr(i, 6)
  47.             brr(r, n + 3) = arr(i, 7)
  48.           End If
  49.           brr(d(s), n + 4) = brr(d(s), n + 4) + 1
  50.           If n = 2 Then Exit For
  51.         Next c
  52.       Next b
  53.     Next a
  54.   Next i
  55.   d.RemoveAll
  56.   If k = 1 Then [j4].Resize(r, n + 4) = brr Else [s4].Resize(r, n + 4) = brr
  57.   r = 0
  58. Next k
  59. End Sub
复制代码
ScreenHunter_26664 May. 09.jpg
ScreenHunter_26669 May. 09.jpg
ScreenHunter_26668 May. 09.jpg

Selection - v.2.xlsx.zip

15.97 KB, 下载次数: 11

发表于 2017-5-10 10:20 | 显示全部楼层
回复

使用道具 举报

 楼主| 发表于 2017-5-10 11:22 | 显示全部楼层
本帖最后由 On_fire 于 2017-5-10 13:03 编辑

老师,


我再表达, 说明一下,

1, 4列有A, B, C, D, 4个原素

1. 先做(任何3个原素)组合, 排列如下:
ABC,
ABD,
ACD,
BCD.

2. 再做(任何2个原素)组合, 排列如下:
AB,
AC,
AD,
BC,
BD,
CD.

上面的自定义组合, 不知能否实现...?


回复

使用道具 举报

 楼主| 发表于 2017-5-10 11:33 | 显示全部楼层
本帖最后由 On_fire 于 2017-5-10 13:01 编辑
On_fire 发表于 2017-5-10 11:22
老师,

我再表达, 说明一下,  

老师,
再说统计(计算), 分为两部分,

1.     有序
AB不等于BA (计算逻辑: 是按位置/排列/顺序)
AB算1
BA算1



2.     没序
AB = BA
AB算2


比如: ABC = ACB = CBA = BAC = CAB = BAC
ABC 算6
回复

使用道具 举报

发表于 2017-5-10 12:56 | 显示全部楼层
还是不懂,放弃啦!
回复

使用道具 举报

 楼主| 发表于 2017-5-10 13:00 | 显示全部楼层
本帖最后由 On_fire 于 2017-5-10 13:34 编辑
zjdh 发表于 2017-5-10 12:56
还是不懂,放弃啦!

谢谢老师关注,

请问是VBA程序没法做到, 还是这题的需求表达不清楚呢?

ScreenHunter_26667 May. 09.jpg
ScreenHunter_26670 May. 10.jpg
回复

使用道具 举报

发表于 2017-5-10 14:04 | 显示全部楼层
放在DATA表内运行,还有点小问题。
  1. Sub aaa()
  2. Dim arr, s$, s1$, i&, j&, d As Object, brr, crr, a&, b&, c&, n&, r&, r1&
  3. Set d = CreateObject("scripting.dictionary")
  4. arr = Range("a4:g" & [a65536].End(3).Row)
  5. n = InputBox("Please input ...")
  6. [j:y].ClearContents
  7. ReDim brr(1 To Application.Combin(4, n) * UBound(arr), 1 To n + 4)
  8. crr = brr
  9. For i = 1 To UBound(arr)
  10.   For a = 1 To 5 - n
  11.     For b = a + 1 To 6 - n
  12.       For c = b + 1 To 7 - n
  13.         s = arr(i, a) & arr(i, b) & arr(i, 6) & arr(i, 7)
  14.         If n = 3 Then s = s & arr(i, c)
  15.         If Not d.exists(s) Then
  16.           r = r + 1
  17.           d(s) = r
  18.           brr(r, 1) = arr(i, a)
  19.           brr(r, 2) = arr(i, b)
  20.           If n = 3 Then brr(r, 3) = arr(i, c)
  21.           brr(r, n + 2) = arr(i, 6)
  22.           brr(r, n + 3) = arr(i, 7)
  23.         End If
  24.         brr(d(s), n + 4) = brr(d(s), n + 4) + 1
  25.         If n = 2 Then Exit For
  26.       Next c
  27.     Next b
  28.   Next a
  29. Next i
  30. d.RemoveAll
  31. For i = 1 To r
  32.   s = ""
  33.   For j = 1 To n
  34.     s = s & brr(i, j)
  35.   Next j
  36.   s1 = s
  37.   s = s & brr(i, UBound(brr, 2) - 2) & brr(i, UBound(brr, 2) - 1)
  38.   s1 = s1 & brr(i, UBound(brr, 2) - 1) & brr(i, UBound(brr, 2) - 2)
  39.   If Not d.exists(s) And Not d.exists(s1) Then
  40.     r1 = r1 + 1
  41.     d(s) = r1
  42.     d(s1) = r1
  43.     For j = 1 To UBound(brr, 2) - 1
  44.       crr(r1, j) = brr(i, j)
  45.     Next j
  46.   End If
  47.   crr(d(s), UBound(brr, 2)) = crr(d(s), UBound(brr, 2)) + brr(i, UBound(brr, 2))
  48. Next i
  49. [j4].Resize(r, n + 4) = brr
  50. [s4].Resize(r1, n + 4) = crr
  51. End Sub
复制代码
回复

使用道具 举报

发表于 2017-5-10 14:05 | 显示全部楼层
注意,inputbox是需要输入组合数(比如2或者3)。
回复

使用道具 举报

 楼主| 发表于 2017-5-10 14:28 | 显示全部楼层
大灰狼1976 发表于 2017-5-10 14:05
注意,inputbox是需要输入组合数(比如2或者3)。

厉害...!
是的, 还有一部分统计未能实现

ScreenHunter_26671 May. 10.jpg
ScreenHunter_26672 May. 10.jpg
回复

使用道具 举报

 楼主| 发表于 2017-5-10 18:18 | 显示全部楼层
本帖最后由 On_fire 于 2017-5-10 18:33 编辑
大灰狼1976 发表于 2017-5-10 14:04
放在DATA表内运行,还有点小问题。

老师,
请问在编程上, 规定了 [ , 是否更容易判断呢?
(蓝色区间 =  AB不等于BA, 紫色区 AB = BA)
ScreenHunter_26672 May. 10.jpg
回复

使用道具 举报

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

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 21:39 , Processed in 7.931875 second(s), 11 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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