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

kid120101

求一个自动的宏，或者可以拖曳的公式。。。。
因为实际要填写的有几千个格子。。。
上次论坛里的一位大神帮我做了一个，但是真的非常抱歉，我的描述有不严谨的地方，导致有些数据无法达到理想的数据。
求大家帮我看看怎么改。上次大神做的代码附件里也有。

拜托各位大神，老师了
求公式1.zip (17.74 KB, 下载次数: 11)

2016-3-31 16:55 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

dsmch

2016-4-1 10:11

手工模拟结果，方便程序比对

跳转到最佳答案楼层

dsmch

手工模拟结果，方便程序比对

kid120101

自己想办法解决了。。。写了2个宏。。。

grf1973

1. Sub grf()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Set d2 = CreateObject("scripting.dictionary")
   
4.     Set d3 = CreateObject("scripting.dictionary")
   
5.     Range("d2:d" & [a65536].End(3).Row) = "错误"
   
6.     arr = Range("a1").CurrentRegion
   
7.     brr = Range("h1").CurrentRegion
   
8.     xmax = Application.WorksheetFunction.Max(Range("J2:J" & [J65536].End(3).Row))  'J列最大值
   
9.     For i = 2 To UBound(brr)  '表二
   
10.         pm = brr(i, 1)     '品名
    
11.         If Not d2.exists(pm) Then d2(pm) = brr(i, 4)
    
12.         d3(pm) = d3(pm) & "," & i       '表二品名和行号相对应
    
13.     Next
    
14.     For i = 2 To UBound(arr)   '表一
    
15.         pm = arr(i, 1)
    
16.         tmp = xmax + 1
    
17.         If Not d.exists(pm) Then     '如果表一第一次出现，取表二第一次出现的日期
    
18.             arr(i, 4) = d2(pm)
    
19.             d(pm) = ""
    
20.             xrr = Split(d3(pm), ",")
    
21.         Else
    
22.             sl = arr(i - 1, 3) '表1上一行数量
    
23.             For k = 1 To UBound(xrr)      '遍历表二该品名各行
    
24.                 kk = Val(xrr(k))
    
25.                 If brr(kk, 3) > sl And brr(kk, 3) < tmp Then  '找到表二大于表1上一行数量的最小值
    
26.                     tmp = brr(kk, 3)
    
27.                     arr(i, 4) = brr(kk, 4)
    
28.                 End If
    
29.             Next
    
30.         End If
    
31.     Next
    
32.     Range("d1").Resize(UBound(arr)) = Application.Index(arr, , 4)
    
33. End Sub
    

复制代码

dsmch

dsmch 发表于 2016-4-1 10:11
手工模拟结果，方便程序比对

这个最佳受之有愧，申请管理员取消{:112:}