Excel精英培训网

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

[已解决]根据指定条件找出最大值

[复制链接]
发表于 2015-3-23 10:29 | 显示全部楼层 |阅读模式
本帖最后由 315617070 于 2015-3-30 11:17 编辑

根据指定条件找出最大值,并将数据放在另一区域,指定条件为日期、代码1、代码2。
相同日期、相同代码2的条件下,找出不同代码1所对应的量的最大值,详见附件,先谢谢各路大侠!

注意:代码2相同的情况,还会有大于或等于1个代码1,因此此时量的最大值需要将所对应的量先合计,在找出最大值。如附加中的黄色区域,之前的附件例子有误,现附加已更新。
最佳答案
2015-3-25 09:33
是这样的,有点小错误,改过来了。
  1. Sub tt()
  2.     arr = [a3].CurrentRegion
  3.     ReDim brr(1 To UBound(arr), 1 To 3)
  4.     ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
  5.     Set d = CreateObject("scripting.dictionary")
  6.     Set d1 = CreateObject("scripting.dictionary")
  7.     For i = 2 To UBound(arr)         '把源数据按前三列去重累加,得到新数组crr
  8.         x = arr(i, 1) & arr(i, 2) & arr(i, 3)
  9.         If Not d1.exists(x) Then
  10.             n = n + 1
  11.             For j = 1 To 4: crr(n, j) = arr(i, j): Next
  12.             d1(x) = n
  13.         Else
  14.             crr(d1(x), 4) = crr(d1(x), 4) + arr(i, 4)
  15.         End If
  16.     Next
  17.    
  18.     For i = 1 To n      '对新数组crr,按日期计算不同代码2的最大值
  19.         x = crr(i, 1): y = crr(i, 4)
  20.         If Not d.exists(x) Then
  21.             m = m + 1
  22.             d(x) = m
  23.             brr(m, 1) = x
  24.         End If
  25.         p = d(x)
  26.         If crr(i, 3) = 1 Then brr(p, 2) = Application.Max(brr(p, 2), y)
  27.         If crr(i, 3) = 0 Then brr(p, 3) = Application.Max(brr(p, 3), y)
  28.     Next
  29.     [f3].Resize(m, 3) = brr
  30. End Sub
复制代码

Book1.rar

8.83 KB, 下载次数: 5

excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2015-3-23 11:13 | 显示全部楼层
回复

使用道具 举报

 楼主| 发表于 2015-3-23 11:47 | 显示全部楼层
爱疯 发表于 2015-3-23 11:13
用数据透视表方便些

谢谢,不过代码2相同的情况下,若代码1有重复,此时的最大值可能为代码1所对应的量的合计。
回复

使用道具 举报

发表于 2015-3-23 14:11 | 显示全部楼层
  1. Sub tt()
  2.     arr = [a3].CurrentRegion
  3.     ReDim brr(1 To UBound(arr), 1 To 3)
  4.     Set d = CreateObject("scripting.dictionary")
  5.     For i = 2 To UBound(arr)
  6.         x = arr(i, 1): y = arr(i, 4)
  7.         If Not d.exists(x) Then
  8.             n = n + 1
  9.             d(x) = n
  10.             brr(n, 1) = x
  11.             brr(n, 2) = y
  12.             brr(n, 3) = y
  13.         Else
  14.             p = d(x)
  15.             If arr(i, 3) = 1 Then brr(n, 2) = Application.Max(brr(n, 2), y)
  16.             If arr(i, 3) = 0 Then brr(n, 3) = Application.Max(brr(n, 3), y)
  17.         End If
  18.     Next
  19.     [f3].Resize(n, 3) = brr
  20. End Sub
复制代码

Book1.rar

14.78 KB, 下载次数: 2

回复

使用道具 举报

发表于 2015-3-23 14:36 | 显示全部楼层
没注意相同累加,修改如下:
  1. Sub tt()
  2.     arr = [a3].CurrentRegion
  3.     ReDim brr(1 To UBound(arr), 1 To 3)
  4.     ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
  5.     Set d = CreateObject("scripting.dictionary")
  6.     Set d1 = CreateObject("scripting.dictionary")
  7.     For i = 2 To UBound(arr)         '把源数据按前三列去重累加,得到新数组crr
  8.         x = arr(i, 1) & arr(i, 2) & arr(i, 3)
  9.         If Not d1.exists(x) Then
  10.             n = n + 1
  11.             For j = 1 To 4: crr(n, j) = arr(i, j): Next
  12.             d1(x) = n
  13.         Else
  14.             crr(d1(x), 4) = crr(d1(x), 4) + arr(i, 4)
  15.         End If
  16.     Next
  17.    
  18.     For i = 1 To n      '对新数组crr,按日期计算不同代码2的最大值
  19.         x = crr(i, 1): y = crr(i, 4)
  20.         If Not d.exists(x) Then
  21.             m = m + 1
  22.             d(x) = m
  23.             brr(m, 1) = x
  24.             brr(m, 2) = y
  25.             brr(m, 3) = y
  26.         Else
  27.             p = d(x)
  28.             If crr(i, 3) = 1 Then brr(p, 2) = Application.Max(brr(p, 2), y)
  29.             If crr(i, 3) = 0 Then brr(p, 3) = Application.Max(brr(p, 3), y)
  30.         End If
  31.     Next
  32.     [f3].Resize(m, 3) = brr
  33. End Sub
复制代码

Book1.rar

16.16 KB, 下载次数: 3

回复

使用道具 举报

 楼主| 发表于 2015-3-25 08:21 | 显示全部楼层
grf1973 发表于 2015-3-23 14:36
没注意相同累加,修改如下:

谢谢大侠,在运行的时候发现:若代码2为0的时候,代码1所对应的量的值小于D3单元格的值时,将会显示D3单元格的值,而不是实际的最大值,若将附件中D7单元格的值改为小于744,如700,那么得到的答案是D3单元格的值744,而实际的最大值应该为MAX(594,700)=700.
回复

使用道具 举报

发表于 2015-3-25 09:33 | 显示全部楼层    本楼为最佳答案   
是这样的,有点小错误,改过来了。
  1. Sub tt()
  2.     arr = [a3].CurrentRegion
  3.     ReDim brr(1 To UBound(arr), 1 To 3)
  4.     ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
  5.     Set d = CreateObject("scripting.dictionary")
  6.     Set d1 = CreateObject("scripting.dictionary")
  7.     For i = 2 To UBound(arr)         '把源数据按前三列去重累加,得到新数组crr
  8.         x = arr(i, 1) & arr(i, 2) & arr(i, 3)
  9.         If Not d1.exists(x) Then
  10.             n = n + 1
  11.             For j = 1 To 4: crr(n, j) = arr(i, j): Next
  12.             d1(x) = n
  13.         Else
  14.             crr(d1(x), 4) = crr(d1(x), 4) + arr(i, 4)
  15.         End If
  16.     Next
  17.    
  18.     For i = 1 To n      '对新数组crr,按日期计算不同代码2的最大值
  19.         x = crr(i, 1): y = crr(i, 4)
  20.         If Not d.exists(x) Then
  21.             m = m + 1
  22.             d(x) = m
  23.             brr(m, 1) = x
  24.         End If
  25.         p = d(x)
  26.         If crr(i, 3) = 1 Then brr(p, 2) = Application.Max(brr(p, 2), y)
  27.         If crr(i, 3) = 0 Then brr(p, 3) = Application.Max(brr(p, 3), y)
  28.     Next
  29.     [f3].Resize(m, 3) = brr
  30. End Sub
复制代码

Book1.rar

15.83 KB, 下载次数: 12

回复

使用道具 举报

发表于 2015-3-25 09:41 | 显示全部楼层
  1. Sub Macro1()
  2. Dim arr, brr, crr, d, d2, i&, zf$, s&, n&, j%
  3. Set d = CreateObject("scripting.dictionary")
  4. Set d2 = CreateObject("scripting.dictionary")
  5. arr = Range("a2").CurrentRegion
  6. ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
  7. For i = 2 To UBound(arr)
  8.     d2(arr(i, 1)) = ""
  9.     zf = arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3)
  10.     If Not d.exists(zf) Then
  11.         s = s + 1
  12.         d(zf) = s
  13.         For j = 1 To UBound(arr, 2)
  14.             brr(s, j) = arr(i, j)
  15.         Next
  16.     Else
  17.         n = d(zf)
  18.         brr(n, 4) = brr(n, 4) + arr(i, 4)
  19.     End If
  20. Next
  21. d.RemoveAll
  22. For i = 1 To s
  23.     zf = brr(i, 1) & "," & brr(i, 3)
  24.     If Not d.exists(zf) Then
  25.         d(zf) = brr(i, 4)
  26.     Else
  27.         If brr(i, 4) > d(zf) Then d(zf) = brr(i, 4)
  28.     End If
  29. Next
  30. crr = [f2:h30000]
  31. a = d2.keys
  32. For i = 0 To d2.Count - 1
  33.     crr(i + 2, 1) = a(i)
  34.     For j = 2 To 3
  35.         zf = a(i) & "," & crr(1, j)
  36.         crr(i + 2, j) = d(zf)
  37.     Next
  38. Next
  39. [f3:h65536] = ""
  40. Range("f2").Resize(d.Count + 1, 3) = crr
  41. End Sub
复制代码

Book1.zip

18.82 KB, 下载次数: 11

评分

参与人数 1 +1 收起 理由
315617070 + 1

查看全部评分

回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-29 15:07 , Processed in 5.716332 second(s), 19 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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