Excel精英培训网

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

[已解决]求助

[复制链接]
发表于 2014-4-5 14:44 | 显示全部楼层 |阅读模式
本帖最后由 云影 于 2014-4-5 17:00 编辑

问题已在附件中描述
谢谢
最佳答案
2014-4-5 16:14
  1. Sub Macro1()
  2. Dim arr, brr, d, i&, s&, zf$
  3. Set d = CreateObject("scripting.dictionary")
  4. arr = Range("a1").CurrentRegion
  5. ReDim brr(1 To UBound(arr), 1 To 4)
  6. For i = 2 To UBound(arr)
  7.     zf = arr(i, 1) & "," & arr(i, 2)
  8.     If Not d.exists(zf) Then
  9.         s = s + 1
  10.         d(zf) = s
  11.         brr(s, 1) = arr(i, 1)
  12.         brr(s, 2) = arr(i, 2)
  13.         brr(s, 3) = arr(i, 4)
  14.         brr(s, 4) = arr(i, 5)
  15.     Else
  16.         If arr(i, 5) > brr(d(zf), 4) Then
  17.             brr(d(zf), 3) = arr(i, 4)
  18.             brr(d(zf), 4) = arr(i, 5)
  19.         End If
  20.     End If
  21. Next
  22. d.RemoveAll
  23. For i = 1 To s
  24.     zf = brr(i, 1) & "," & brr(i, 2)
  25.     d(zf) = brr(i, 3)
  26. Next
  27. For i = 2 To UBound(arr)
  28.     zf = arr(i, 1) & "," & arr(i, 2)
  29.     If arr(i, 3) = 999 Then Cells(i, 4) = d(zf)
  30. Next
  31. End Sub
复制代码

求助.rar

7.99 KB, 下载次数: 18

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

使用道具 举报

 楼主| 发表于 2014-4-5 15:18 | 显示全部楼层
hwc2ycy 发表于 2014-4-5 15:07
只替换商品编码为999的?

是的
老师
回复

使用道具 举报

发表于 2014-4-5 16:04 | 显示全部楼层
如果有两个商品类的数量是相同的,那又该以哪个为准了?
回复

使用道具 举报

 楼主| 发表于 2014-4-5 16:09 | 显示全部楼层
hwc2ycy 发表于 2014-4-5 16:04
如果有两个商品类的数量是相同的,那又该以哪个为准了?

{:2412:}这点我没有描述清楚, 如果单价相同取哪一个都可以,谢谢老师
回复

使用道具 举报

发表于 2014-4-5 16:14 | 显示全部楼层    本楼为最佳答案   
  1. Sub Macro1()
  2. Dim arr, brr, d, i&, s&, zf$
  3. Set d = CreateObject("scripting.dictionary")
  4. arr = Range("a1").CurrentRegion
  5. ReDim brr(1 To UBound(arr), 1 To 4)
  6. For i = 2 To UBound(arr)
  7.     zf = arr(i, 1) & "," & arr(i, 2)
  8.     If Not d.exists(zf) Then
  9.         s = s + 1
  10.         d(zf) = s
  11.         brr(s, 1) = arr(i, 1)
  12.         brr(s, 2) = arr(i, 2)
  13.         brr(s, 3) = arr(i, 4)
  14.         brr(s, 4) = arr(i, 5)
  15.     Else
  16.         If arr(i, 5) > brr(d(zf), 4) Then
  17.             brr(d(zf), 3) = arr(i, 4)
  18.             brr(d(zf), 4) = arr(i, 5)
  19.         End If
  20.     End If
  21. Next
  22. d.RemoveAll
  23. For i = 1 To s
  24.     zf = brr(i, 1) & "," & brr(i, 2)
  25.     d(zf) = brr(i, 3)
  26. Next
  27. For i = 2 To UBound(arr)
  28.     zf = arr(i, 1) & "," & arr(i, 2)
  29.     If arr(i, 3) = 999 Then Cells(i, 4) = d(zf)
  30. Next
  31. End Sub
复制代码
回复

使用道具 举报

发表于 2014-4-5 16:15 | 显示全部楼层
………………

求助.zip

9.86 KB, 下载次数: 7

回复

使用道具 举报

发表于 2014-4-5 16:21 | 显示全部楼层
  1. Option Explicit

  2. Sub test()
  3.     Dim arr
  4.     arr = Range("a1").CurrentRegion.Value
  5.     Dim d1 As Dictionary
  6.     Dim dPrice As Dictionary
  7.     Dim d2 As Dictionary
  8.     Dim d3 As Dictionary

  9.     Set d1 = New Dictionary
  10.     Set dPrice = New Dictionary
  11.     Set d2 = New Dictionary
  12.     Set d3 = New Dictionary
  13.     Dim i&, t#, str$
  14.     t = Timer
  15.     For i = 2 To UBound(arr)
  16.         str = arr(i, 1) & "#" & arr(i, 2)
  17.         If arr(i, 3) <> 999 Then
  18.             '店面#单号
  19.             '            '统计商品次数
  20.             '            dCount(str & arr(i, 4)) = dCount(str & arr(i, 4)) + 1
  21.             If d1.Exists(str) Then
  22.                 d1(str)(arr(i, 4)) = d1(str)(arr(i, 4)) + 1

  23.                 If arr(i, 5) > dPrice(str)(arr(i, 4)) Then
  24.                     dPrice(str)(arr(i, 4)) = arr(i, 5)
  25.                 End If
  26.             Else
  27.                 '商品分类,次数
  28.                 d1.Add str, New Dictionary
  29.                 d1(str).Add arr(i, 4), 1
  30.                 '商品分类,价格
  31.                 dPrice.Add str, New Dictionary
  32.                 dPrice(str).Add arr(i, 4), arr(i, 5)
  33.             End If
  34.         Else
  35.             d2.Add i, str
  36.         End If
  37.     Next

  38.     Dim j
  39.     For Each j In d2.Keys
  40.         str = arr(j, 1) & "#" & arr(j, 2)
  41.         Dim item1 As Dictionary
  42.         Dim subkey, subitem
  43.         Set item1 = d1(str)

  44.         subkey = item1.Keys
  45.         subitem = item1.Items
  46.         If Not d3.Exists(str) Then
  47.             If WorksheetFunction.Max(subitem) <> 1 Then
  48.                 Dim k&, lCountMax&, lCountStr
  49.                 lCountMax = subitem(0)
  50.                 lCountStr = subkey(0)
  51.                 For k = 1 To UBound(subitem)
  52.                     If lCountMax < subitem(k) Then
  53.                         lCountMax = subitem(k)
  54.                         lCountStr = subkey(k)
  55.                     End If
  56.                 Next
  57.                 d3.Add arr(j, 1) & "#" & arr(j, 2), lCountStr
  58.                 arr(j, 4) = lCountStr
  59.             Else
  60.                 Set item1 = dPrice(str)
  61.                 subkey = item1.Keys
  62.                 subitem = item1.Items
  63.                 lCountMax = subitem(0)
  64.                 lCountStr = subkey(0)
  65.                 For k = 1 To UBound(subitem)
  66.                     If lCountMax < subitem(k) Then
  67.                         lCountMax = subitem(k)
  68.                         lCountStr = subkey(k)
  69.                     End If
  70.                 Next
  71.                 d3.Add str, lCountStr
  72.                 arr(j, 4) = lCountStr
  73.             End If
  74.         Else
  75.             arr(j, 4) = d3(str)
  76.         End If
  77.     Next
  78.     '结果数组,写入位置自行设置
  79.     Range("h26").Resize(UBound(arr), UBound(arr, 2)).Value = arr

  80. End Sub
复制代码
楼主用大数据测测,看看是不是对的,现有的数据测出来是对的。
回复

使用道具 举报

发表于 2014-4-5 16:27 | 显示全部楼层
  1. Sub Macro1()
  2. Dim arr, brr, crr, d, i&, s&, zf$
  3. Set d = CreateObject("scripting.dictionary")
  4. arr = Range("a1").CurrentRegion
  5. ReDim brr(1 To UBound(arr), 1 To 4)
  6. ReDim crr(1 To UBound(arr) - 1, 1 To 1)
  7. For i = 2 To UBound(arr)
  8.     zf = arr(i, 1) & "," & arr(i, 2)
  9.     If Not d.exists(zf) Then
  10.         s = s + 1
  11.         d(zf) = s
  12.         brr(s, 1) = arr(i, 1)
  13.         brr(s, 2) = arr(i, 2)
  14.         brr(s, 3) = arr(i, 4)
  15.         brr(s, 4) = arr(i, 5)
  16.     Else
  17.         If arr(i, 5) > brr(d(zf), 4) Then
  18.             brr(d(zf), 3) = arr(i, 4)
  19.             brr(d(zf), 4) = arr(i, 5)
  20.         End If
  21.     End If
  22. Next
  23. d.RemoveAll
  24. For i = 1 To s
  25.     zf = brr(i, 1) & "," & brr(i, 2)
  26.     d(zf) = brr(i, 3)
  27. Next
  28. For i = 2 To UBound(arr)
  29.     zf = arr(i, 1) & "," & arr(i, 2)
  30.     If arr(i, 3) = 999 Then crr(i - 1, 1) = d(zf) Else crr(i - 1, 1) = arr(i, 4)
  31. Next
  32. Range("d2").Resize(UBound(crr)) = crr
  33. End Sub
复制代码
如果是大数据,单元格输入改为数组
回复

使用道具 举报

发表于 2014-4-5 16:36 | 显示全部楼层
dsmch 发表于 2014-4-5 16:27
如果是大数据,单元格输入改为数组

我想复杂了,
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-29 13:40 , Processed in 0.548172 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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