设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 求代码。（额外重赏30块大洋^_^）
数据透视表40+个常用小技巧，让你一次学会！
12下一页
返回列表 发新帖
查看: 5560|回复: 10

[已解决]求代码。（额外重赏30块大洋^_^）

[复制链接]
发表于 2014-9-25 10:11 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
30学分
最近代码看了就晕。。。哪位大虾帮帮俺
最佳答案
月排行榜 / 总排行榜
dsmch
2014-9-25 10:11
  1. Sub Macro1()
  2. Dim arr, brr, d, d2, d3, i&
  3. Set d = CreateObject("scripting.dictionary")
  4. Set d2 = CreateObject("scripting.dictionary")
  5. Set d3 = CreateObject("scripting.dictionary")
  6. arr = Sheet1.Range("a1").CurrentRegion
  7. brr = Sheet2.Range("a1").CurrentRegion
  8. For i = 2 To UBound(arr)
  9.     d(arr(i, 1)) = arr(i, 3)
  10. Next
  11. For i = 2 To UBound(brr)
  12.     d2(brr(i, 1)) = i
  13.     d3(brr(i, 1)) = d3(brr(i, 1)) + brr(i, 3)
  14. Next
  15. For i = 2 To UBound(brr)
  16.     If d(brr(i, 1)) > d3(brr(i, 1)) Then
  17.         If i <> d2(brr(i, 1)) Then brr(i, 3) = 0 Else brr(i, 3) = d3(brr(i, 1)) - d(brr(i, 1))
  18.     Else
  19.         x = brr(i, 3)
  20.         If brr(i, 3) < d(brr(i, 1)) Then
  21.             brr(i, 3) = 0
  22.             d(brr(i, 1)) = d(brr(i, 1)) - x
  23.         Else
  24.             brr(i, 3) = x - d(brr(i, 1))
  25.             d(brr(i, 1)) = 0
  26.         End If
  27.     End If
  28. Next
  29. Sheet2.Range("h1").Resize(UBound(brr), UBound(brr, 2)) = brr
  30. End Sub
复制代码

求助.zip

7.92 KB, 下载次数: 29

最佳答案

dsmch

查看完整内容
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
dsmch
发表于 2014-9-25 10:11 | 显示全部楼层    本楼为最佳答案   
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
  1. Sub Macro1()
  2. Dim arr, brr, d, d2, d3, i&
  3. Set d = CreateObject("scripting.dictionary")
  4. Set d2 = CreateObject("scripting.dictionary")
  5. Set d3 = CreateObject("scripting.dictionary")
  6. arr = Sheet1.Range("a1").CurrentRegion
  7. brr = Sheet2.Range("a1").CurrentRegion
  8. For i = 2 To UBound(arr)
  9.     d(arr(i, 1)) = arr(i, 3)
  10. Next
  11. For i = 2 To UBound(brr)
  12.     d2(brr(i, 1)) = i
  13.     d3(brr(i, 1)) = d3(brr(i, 1)) + brr(i, 3)
  14. Next
  15. For i = 2 To UBound(brr)
  16.     If d(brr(i, 1)) > d3(brr(i, 1)) Then
  17.         If i <> d2(brr(i, 1)) Then brr(i, 3) = 0 Else brr(i, 3) = d3(brr(i, 1)) - d(brr(i, 1))
  18.     Else
  19.         x = brr(i, 3)
  20.         If brr(i, 3) < d(brr(i, 1)) Then
  21.             brr(i, 3) = 0
  22.             d(brr(i, 1)) = d(brr(i, 1)) - x
  23.         Else
  24.             brr(i, 3) = x - d(brr(i, 1))
  25.             d(brr(i, 1)) = 0
  26.         End If
  27.     End If
  28. Next
  29. Sheet2.Range("h1").Resize(UBound(brr), UBound(brr, 2)) = brr
  30. End Sub
复制代码

点评

顺⑦.zì繎。
精测试 达人结果无误，速度较优，在此感谢达人帮住。设为最佳答案以及悬赏的30大洋。  发表于 2014-9-26 10:04
回复

使用道具 举报

易安1
发表于 2014-9-25 10:15 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
版版又调皮了
回复

使用道具 举报

发表于 2014-9-25 10:20 | 显示全部楼层
版主好大手笔
回复

使用道具 举报

发表于 2014-9-25 10:26 | 显示全部楼层
下不了手哈！有如下几个问题：{:26:}
1、销售表的品名都是不重复的吗？
2、库存表都是按品名和仓库编号排序的吗？

点评

顺⑦.zì繎。
销售表品名不重复。库存表品名与仓库编号实际排序为乱序。  发表于 2014-9-25 12:03
回复

使用道具 举报

发表于 2014-9-25 11:04 | 显示全部楼层
师傅还没休息呢

点评

as0810114
赶紧给你师父解决掉。  发表于 2014-9-25 12:52

评分

参与人数 1 +3 收起 理由
神隐汀渚 + 3 赶紧给你师父解决掉。

查看全部评分

回复

使用道具 举报

su45
发表于 2014-9-25 11:18 | 显示全部楼层
销售这页中的 箱数 数量 是不用在库取中提取的吧？

点评

顺⑦.zì繎。
这个可以在库存提取也可以手动输入。这个问题不涉及本帖内容。^_^。。。。  发表于 2014-9-25 12:04
回复

使用道具 举报

xdragon
发表于 2014-9-25 13:03 | 显示全部楼层
本帖最后由 xdragon 于 2014-9-25 14:06 编辑
  1. Sub test()
  2.    Dim arr, brr, i&, j%, tmp%, lastrow&
  3.    arr = Sheets("库存").Range("A1").CurrentRegion.Value
  4.    brr = Sheets("销售").Range("A1").CurrentRegion.Value
  5.    For j = 2 To UBound(brr)
  6.        tmp = brr(j, 3)
  7.        For i = 2 To UBound(arr)
  8.            If brr(j, 1) = arr(i, 1) Then
  9.                lastrow = i
  10.                If arr(i, 3) < tmp Then
  11.                    tmp = tmp - arr(i, 3)
  12.                    arr(i, 3) = 0
  13.                Else
  14.                    arr(i, 3) = arr(i, 3) - tmp
  15.                    tmp = 0
  16.                    Exit For
  17.                End If
  18.            End If
  19.        Next
  20.        If tmp > 0 Then arr(lastrow, 3) = -tmp
  21.    Next
  22.    Sheets("销售").Range("D24").Resize(UBound(arr), UBound(arr, 2)) = arr
  23. End Sub
复制代码
不知道是不是用数组做。。。

点评

顺⑦.zì繎。
多谢龙哥鼎立相助，经测试楼下代码速度较优，为此最佳设置为楼下。  发表于 2014-9-26 10:01

评分

参与人数 2 +23 金币 +10 收起 理由
顺⑦.zì繎。 + 20 + 10 赞一个!
神隐汀渚 + 3 大师 啊 膜拜

查看全部评分

回复

使用道具 举报

dsmch
发表于 2014-9-25 13:51 | 显示全部楼层
………………

求助.zip

11.21 KB, 下载次数: 13
回复

使用道具 举报

发表于 2014-9-25 13:55 | 显示全部楼层
顺版不厚道哈！用VBA竟然不保存为“*.xlsm”格式！{:02:}
  1. Sub test()
  2.     Dim d As Object
  3.     Dim ar, br, cr
  4.     Dim i As Long, j As Long
  5.     Dim zs As Double
  6.     Set d = CreateObject("scripting.dictionary")
  7.     ar = Sheet1.Cells(1, 1).CurrentRegion
  8.     br = Sheet2.Cells(1, 1).CurrentRegion
  9.     For i = 2 To UBound(br)
  10.         If d.exists(br(i, 1)) Then
  11.             d(br(i, 1)) = d(br(i, 1)) & vbTab & i
  12.         Else
  13.             d.Add br(i, 1), i
  14.         End If
  15.     Next i
  16.     For i = 2 To UBound(ar)
  17.         If d.exists(ar(i, 1)) Then
  18.             cr = Split(d(ar(i, 1)), vbTab)
  19.             For j = 0 To UBound(cr)
  20.                 zs = zs + br(cr(j), 3)
  21.                 If zs < ar(i, 3) Then
  22.                     If j = UBound(cr) Then
  23.                         br(cr(j), 3) = zs - ar(i, 3)
  24.                     Else
  25.                         br(cr(j), 3) = 0
  26.                     End If
  27.                 Else
  28.                     br(cr(j), 3) = zs - ar(i, 3)
  29.                     Exit For
  30.                 End If
  31.             Next j
  32.             zs = 0
  33.         End If
  34.     Next i
  35.     With Sheet3.Cells(1, 1)
  36.         .Resize(Rows.Count, 6).ClearContents
  37.         .Resize(UBound(br), 6) = br
  38.     End With
  39. End Sub
复制代码

求助.zip

20.56 KB, 下载次数: 0

点评

顺⑦.zì繎。
经测试代码正确无误。但楼上代码速度比较快。  发表于 2014-9-26 10:02

评分

参与人数 1 +20 金币 +10 收起 理由
顺⑦.zì繎。 + 20 + 10 赞一个!

查看全部评分

回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-4-26 04:09 , Processed in 0.704990 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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