求助如何自动填日期

jsyzlibin

请教各位，附件中H列自动填日期，开始结束日期在B列，H列日期在开始和结束日期之间填写每月21日，同时将E列日期插入到H列日期中，结果如同M列，谢谢。

chxw68

1. Sub test()
   
2.     Dim r&, i&
   
3.     Dim arr, brr
   
4.     With Worksheets("sheet1")
   
5.         riqi = .Range("b3:b4")
   
6.         ReDim brr(1 To 1000, 1 To 2)
   
7.         m = 0
   
8.         For i = 1 To UBound(riqi)
   
9.             m = m + 1
   
10.             brr(m, 1) = riqi(i, 1)
    
11.         Next
    
12.         rq = DateSerial(Year(riqi(1, 1)), Month(riqi(1, 1)), 21)
    
13.         Do While rq <= riqi(2, 1)
    
14.             m = m + 1
    
15.             brr(m, 1) = rq
    
16.             rq = DateAdd("m", 1, rq)
    
17.         Loop
    
18.         r = .Cells(.Rows.Count, 5).End(xlUp).Row
    
19.         arr = .Range("e3:e" & r)
    
20.         For i = 1 To UBound(arr)
    
21.             m = m + 1
    
22.             brr(m, 1) = arr(i, 1)
    
23.         Next
    
24.         .Range("h4").Resize(m, 2) = brr
    
25.         .Range("h4").Resize(m, 2).Sort key1:=.Range("h4"), order1:=xlAscending, Header:=xlNo
    
26.     End With
    
27. End Sub
    

复制代码

chxw68

详见附件。

jsyzlibin

chxw68 发表于 2024-4-28 16:45
详见附件。

谢谢，基本可以了，有个小问题，当E列中的某个日期正好是21号的，在H列会有两个这个日期

tanglf188

请参考

DAY18883320729

把brr(m, 1) = arr(i, 1)放进判断里面就可以了。

1.             If Day(arr(i, 1)) <> 21 Then
   
2.                 brr(m, 1) = arr(i, 1)
   
3.             End If

复制代码

chxw68

jsyzlibin 发表于 2024-4-28 17:02
谢谢，基本可以了，有个小问题，当E列中的某个日期正好是21号的，在H列会有两个这个日期

那就用字典吧。

baofa2

1. Sub test1() '参与练习
   
2.   Dim ar, br, cr, alColl As Object
   
3.   Dim y As Long, m As Long, d As Long
   
4.   Dim start_ As Long, end_ As Long
   
5.   
   
6.   d = 21
   
7.   Set alColl = CreateObject("System.Collections.ArrayList")
   
8.   
   
9.   br = Range("E3", Cells(Rows.Count, "E").End(xlUp).Offset(1)).Value
   
10.   For y = 1 To UBound(br) - 1
    
11.     If Day(br(y, 1)) <> d Then alColl.Add br(y, 1)
    
12.   Next
    
13.   
    
14.   cr = Range("B3:B4").Value
    
15.   alColl.Add cr(1, 1)
    
16.   alColl.Add cr(2, 1)
    
17.   
    
18.   start_ = Val(Format(cr(1, 1), "yyyymm"))
    
19.   end_ = Val(Format(cr(2, 1), "yyyymm"))
    
20.   
    
21.   For y = Year(cr(1, 1)) To Year(cr(2, 1))
    
22.     For m = 1 To 12
    
23.       If Val(y & Format(m, "00")) >= start_ Then
    
24.         If Val(y & Format(m, "00")) <= end_ Then
    
25.           If DateSerial(y, m, d) < cr(2, 1) Then alColl.Add DateSerial(y, m, d)
    
26.         End If
    
27.       End If
    
28.     Next
    
29.   Next
    
30.   alColl.Sort
    
31.   ar = WorksheetFunction.Transpose(alColl.ToArray)
    
32.   
    
33.   With Range("H3")
    
34.     .CurrentRegion.ClearContents
    
35.     .Resize(, 2) = Split("日期点 天数")
    
36.     .Offset(1).Resize(UBound(ar)).Value = ar
    
37.   End With
    
38.   
    
39.   Set alColl = Nothing
    
40.   Beep
    
41. End Sub

复制代码

jsyzlibin

chxw68 发表于 2024-4-28 17:55
那就用字典吧。

第一个日期应该是开始日期，当开始日期是21号之后日期时，不应该出现这个月的21号。

chxw68

修改好了。