小白一枚，求助高手！！怎么实现日期按要求自动填充，非常感谢！！！

梦无痕1981

批次	型号	数量						日期	批次	型号	数量
17986315	G2800+CS31W2+B007W-EFBY	50	原数据				想要的结果	2017/7/1	17986315	G2800+CS31W2+B007W-EFBY	50
17986316	G2800+CS31W2+B007W-EFBY	250					自动填充日期，格式为文本	2017/7/1	17986316	G2800+CS31W2+B007W-EFBY	250
TC7090HP01	C261-Q205PP	500						2017/7/1	TC7090HP01	C261-Q205PP	500
TC7061HP13	LC506-T423	500						2017/7/1	TC7061HP13	LC506-T423	500
17981877	D349E12-BRBG	519						2017/7/1	17981877	D349E12-BRBG	519
17988262	D201A04-CSF	1548						2017/7/1	17988262	D201A04-CSF	1548
17988256	LA326T-FPK	700						2017/7/1	17988256	LA326T-FPK	700
TC7080HP09	GB105-Q208GG	100						2017/7/1	TC7080HP09	GB105-Q208GG	100
TC7080HP10	GB105-Q207PP	500						2017/7/1	TC7080HP10	GB105-Q207PP	500
TC7087HP09	LC520-T403P	100						2017/7/1	TC7087HP09	LC520-T403P	100
TC7087HP08	LC520-T454P	550						2017/7/1	TC7087HP08	LC520-T454P	550
TC7083HP28	LD399Q-T213	800						2017/7/1	TC7083HP28	LD399Q-T213	800
1	1	1							1	1	1
2	2	2							2	2	2
3	3	3							3	3	3
17986315	G2800+CS31W2+B007W-EFMG	100						2017/7/4	17986315	G2800+CS31W2+B007W-EFMG	100
17986316	G2800+CS31W2+B007W-EFMG	200						2017/7/4	17986316	G2800+CS31W2+B007W-EFMG	200
TC7090HP01	C261-Q205PP	500						2017/7/4	TC7090HP01	C261-Q205PP	500
TC7061HP13	LC506-T423	500						2017/7/4	TC7061HP13	LC506-T423	500
17981877	D349E12-BRBG	408						2017/7/4	17981877	D349E12-BRBG	408
17982810	D349U-UFOG	111						2017/7/4	17982810	D349U-UFOG	111
17988262	D201A04-CSF	1548						2017/7/4	17988262	D201A04-CSF	1548
17988256	LA326T-FPK	400						2017/7/4	17988256	LA326T-FPK	400
17988256	LA326T-FBL	300						2017/7/4	17988256	LA326T-FBL	300
17981875	C3028-TBSG	608						2017/7/4	17981875	C3028-TBSG	608
TC7090HP03	GB105-Q208GG	500						2017/7/4	TC7090HP03	GB105-Q208GG	500
TC7087HP08	LC520-T454P	650						2017/7/4	TC7087HP08	LC520-T454P	650
TC7083HP28	LD399Q-T213	200						2017/7/4	TC7083HP28	LD399Q-T213	200
TC7083HP29	LD399Q-T213	600						2017/7/4	TC7083HP29	LD399Q-T213	600
4	4	4							4	4	4

chxw68

日期数据是怎么来的？就是怎么知道该填什么日期？

梦无痕1981

chxw68 发表于 2017-8-16 16:52
日期数据是怎么来的？就是怎么知道该填什么日期？

根据原数据里的1，2，3来填充对应的日期， 数据1以上的行填充7月1日，或者8月1日

凌空一羽

1. Sub lkyy()
   
2. m = Range("a1").End(4).Row
   
3. ar = Range("a1:d" & m + 1)
   
4. For i = 2 To m
   
5.     If ar(i, 1) <> ar(i, 2) Then
   
6.         k = 0
   
7.         Do Until ar(k + i, 1) = ar(k + i, 2)
   
8.             k = k + 1
   
9.         Loop
   
10.         If k + i = m + 1 Then
    
11.             For j = 2 To i
    
12.                 If ar(j, 1) = ar(j, 2) Then l = j
    
13.             Next
    
14.             ar(i, 4) = DateSerial(2017, 7, ar(l, 1) + 1)
    
15.         Else
    
16.             ar(i, 4) = DateSerial(2017, 7, ar(k + i, 1))
    
17.         End If
    
18.     End If
    
19. Next
    
20. Range("a1").Resize(m, 4) = ar
    
21. [d1] = "日期"
    
22. Range("d2:d" & m).NumberFormat = "yyyy-m-d"
    
23. End Sub

复制代码

梦无痕1981

凌空一羽 发表于 2017-8-16 22:53

能不能实现自动判断同一天的批次号如果重复，高亮显示？谢谢！！！

日期	批次	型号	数量
2017/7/1	17986315	G2800+CS31W2+B007W-EFBY	50
2017/7/1	17986316	G2800+CS31W2+B007W-EFBY	250
2017/7/1	TC7090HP01	C261-Q205PP	500
2017/7/1	TC7061HP13	LC506-T423	500
2017/7/1	17981877	D349E12-BRBG	519		能不能自动判断同一天的批次号是不是有重复，如果重复，自动高亮显示
2017/7/1	17988262	D201A04-CSF	1548
2017/7/1	17988256	LA326T-FPK	700
2017/7/1	TC7080HP09	GB105-Q208GG	100
2017/7/1	TC7080HP10	GB105-Q207PP	500
2017/7/1	TC7087HP09	LC520-T403P	100		例如7月4日的17988256批次，
2017/7/1	TC7087HP08	LC520-T454P	550
2017/7/1	TC7083HP28	LD399Q-T213	800
	1	1	1
	2	2	2
	3	3	3
2017/7/4	17986315	G2800+CS31W2+B007W-EFMG	100
2017/7/4	17986316	G2800+CS31W2+B007W-EFMG	200
2017/7/4	TC7090HP01	C261-Q205PP	500
2017/7/4	TC7061HP13	LC506-T423	500
2017/7/4	17981877	D349E12-BRBG	408
2017/7/4	17982810	D349U-UFOG	111
2017/7/4	17988262	D201A04-CSF	1548
2017/7/4	17988256	LA326T-FPK	400
2017/7/4	17988256	LA326T-FBL	300
2017/7/4	17981875	C3028-TBSG	608
2017/7/4	TC7090HP03	GB105-Q208GG	500
2017/7/4	TC7087HP08	LC520-T454P	650
2017/7/4	TC7083HP28	LD399Q-T213	200
2017/7/4	TC7083HP29	LD399Q-T213	600
	4	4	4

凌空一羽

梦无痕1981 发表于 2017-8-17 08:49
能不能实现自动判断同一天的批次号如果重复，高亮显示？谢谢！！！

1. Sub lkyy()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. ar = Range("a1").CurrentRegion
   
4. For i = 2 To UBound(ar)
   
5.     If ar(i, 1) <> "" Then
   
6.         t = ar(i, 1) & "|" & ar(i, 2)
   
7.         d(t) = d(t) + 1
   
8.     End If
   
9. Next
   
10. For i = 2 To UBound(ar)
    
11.     t = ar(i, 1) & "|" & ar(i, 2)
    
12.     If d.exists(t) Then If d(t) > 1 Then Cells(i, 2).Interior.Color = 49407
    
13. Next
    
14. Set d = Nothing
    
15. End Sub

复制代码

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Dim flg As Boolean
   
6.   Set d = CreateObject("scripting.dictionary")
   
7.   flg = True
   
8.   With Worksheets("sheet1")
   
9.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
10.     arr = .Range("a2:c" & r)
    
11.     ReDim brr(1 To UBound(arr), 1 To 1)
    
12.     For i = UBound(arr) To 1 Step -1
    
13.       If IsNumeric(arr(i, 1)) And arr(i, 1) >= 1 And arr(i, 1) <= 31 Then
    
14.         rq = CDate("2017-7-" & arr(i, 1))
    
15.         If flg Then
    
16.           rq0 = rq
    
17.           flg = False
    
18.         End If
    
19.       Else
    
20.         brr(i, 1) = rq
    
21.       End If
    
22.     Next
    
23.     For i = UBound(arr) To 1 Step -1
    
24.       If IsNumeric(arr(i, 1)) And arr(i, 1) >= 1 And arr(i, 1) <= 31 Then
    
25.         Exit For
    
26.       End If
    
27.       brr(i, 1) = rq0 + 1
    
28.     Next
    
29.     .Range("i2").Resize(UBound(brr), 1) = brr
    
30.     .Range("j2").Resize(UBound(arr), UBound(arr, 2)) = arr
    
31.     For i = 1 To UBound(arr)
    
32.       If Not d.exists(brr(i, 1)) Then
    
33.         Set d(brr(i, 1)) = CreateObject("scripting.dictionary")
    
34.       End If
    
35.       If Not d(brr(i, 1)).exists(arr(i, 1)) Then
    
36.         d(brr(i, 1))(arr(i, 1)) = i
    
37.       Else
    
38.         m = d(brr(i, 1))(arr(i, 1))
    
39.         .Cells(m + 1, 9).Resize(1, 4).Interior.ColorIndex = 6
    
40.         .Cells(i + 1, 9).Resize(1, 4).Interior.ColorIndex = 6
    
41.       End If
    
42.     Next
    
43.       
    
44.   End With
    
45. End Sub
    

复制代码

chxw68

详见附件。

梦无痕1981

chxw68 发表于 2017-8-17 10:01
详见附件。

您好，能不能帮忙看下附件代码，运行时总是提示类型不匹配，谢谢！
代码是把sheet 1的数据填充到sheet 2
如果想要保存sheet 2 原来的单元格格式，该怎么优化下代码呢？多谢！！