Excel精英培训网

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

[已解决]求自动匹配品名,填写日期要求的代码

[复制链接]
发表于 2016-3-18 17:31 | 显示全部楼层 |阅读模式
求一个自动的宏,或者可以拖曳的公式。。。。
因为实际要填写的有几千个格子。。。
自学了一些VBA语句,自己试着写了一个然后无限循环卡死。。。单个品名的语句到是自己会写,要匹配品名的就不会了。
表格见附件,详细的要求也写在附件里了。

拜托各位大神,老师了
求公式.zip (11.52 KB, 下载次数: 11)
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
 楼主| 发表于 2016-3-18 17:35 | 显示全部楼层
可能有点复杂,拜托大家了。。。。
回复

使用道具 举报

发表于 2016-3-19 11:37 | 显示全部楼层
  1. Sub Macro1()
  2. Dim arr, brr, crr, drr, d, d2, d3, i&, j&
  3. Set d = CreateObject("scripting.dictionary")
  4. Set d2 = CreateObject("scripting.dictionary")
  5. Set d3 = CreateObject("scripting.dictionary")
  6. arr = Range("a1").CurrentRegion
  7. brr = Range("h1").CurrentRegion
  8. ReDim crr(1 To 2000, 1 To 4)
  9. ReDim drr(1 To UBound(arr), 1 To 1)
  10. For i = 2 To UBound(brr)
  11.     zf = brr(i, 1) & "," & brr(i, 3)
  12.     If Not d2.exists(zf) Then d2(zf) = brr(i, 4)
  13.    If Not d.exists(brr(i, 1)) Then
  14.         s = s + 1
  15.         d(brr(i, 1)) = s
  16.         crr(s, 1) = brr(i, 3)
  17.         crr(s, 2) = brr(i, 3)
  18.         crr(s, 3) = i
  19.         crr(s, 4) = i
  20.    Else
  21.         n = d(brr(i, 1))
  22.         If brr(i, 3) < crr(n, 1) Then crr(n, 1) = brr(i, 3): crr(n, 3) = i
  23.         If brr(i, 3) > crr(n, 2) Then crr(n, 2) = brr(i, 3): crr(n, 4) = i
  24.    End If
  25. Next
  26. For i = 2 To UBound(arr)
  27.     n = d(arr(i, 1))
  28.     If arr(i, 3) > crr(n, 1) Then
  29.         For j = crr(n, 3) To crr(n, 4)
  30.             sz = arr(i, 3) - brr(j, 3)
  31.             If sz > 0 And Not d3.exists(sz) Then d3(sz) = j
  32.         Next
  33.         drr(i, 1) = brr(d3(Application.Min(d3.keys)), 4)
  34.         d3.RemoveAll
  35.     End If
  36.     zf = arr(i, 1) & "," & arr(i, 3)
  37.     If d2.exists(zf) Then drr(i, 1) = d2(zf)
  38.     If arr(i, 3) > crr(n, 2) Or arr(i, 3) < crr(n, 1) Then drr(i, 1) = brr(crr(n, 3), 4)
  39. Next
  40. Range("f1").Resize(UBound(drr)) = drr
  41. End Sub
复制代码
回复

使用道具 举报

发表于 2016-3-19 11:44 | 显示全部楼层    本楼为最佳答案   
………………

求公式.zip

27.88 KB, 下载次数: 7

回复

使用道具 举报

 楼主| 发表于 2016-3-21 10:35 | 显示全部楼层
dsmch 发表于 2016-3-19 11:44
………………

谢谢大神。。。太神奇了。。。
回复

使用道具 举报

 楼主| 发表于 2016-3-21 11:36 | 显示全部楼层
dsmch 发表于 2016-3-19 11:44
………………

能大概解释一下里面的语句吗。。。。真的好厉害,有一些我看不太懂。。。。

点评

论坛上有代码编辑器,搜一下相关主题  发表于 2016-3-21 12:04
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-28 21:13 , Processed in 0.643586 second(s), 14 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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