[已解决]请问如何用vba按以下规则填写年份和月份

evenschen

请问如何用vba按以下规则填写年份和月份，谢谢！

4位数字分别代表“年年月月”，1206即代表12年，06即代表6月，以下的要求就是自动填充从12年6月到13年8月

起始期间 1206
结束期间 1308

最后填充的结果是
1206
1207
1208
1209
1210
1211
1212
1301
1302
1303
1304
1305
1306
1307
1308

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-9-20 20:19

1. Sub myfill()
   
2.     Dim dStart As Date, dEnd As Date
   
3.     Dim strTemp As String
   
4.     Dim arr(1 To 1000, 1 To 1), i As Integer
   
5. 
   
6.     strTemp = Range("b2").Value
   
7.     dStart = CDate(Format(strTemp & "01", "1900/00/00"))
   
8.     strTemp = Range("b3").Value
   
9.     dEnd = CDate(Format(strTemp & "01", "1900/00/00"))
   
10.     Do While dStart <= dEnd
    
11.         i = i + 1
    
12.         arr(i, 1) = Format(dStart, "yymm")
    
13.         dStart = DateAdd("m", 1, dStart)
    
14.     Loop
    
15.     If i Then
    
16.         Range("b6").Resize(i).Value = arr
    
17.         MsgBox "填充完成"
    
18.     Else
    
19.         MsgBox "日期无效"
    
20.     End If
    
21. End Sub

复制代码

跳转到最佳答案楼层

CheryBTL

1. Sub 按钮1_Click()
   
2.     Dim i As Integer
   
3.     Dim Mmin As Integer, Mmax As Integer
   
4.     Dim re
   
5.     Mmin = Range("B2")
   
6.     Mmax = Range("B3")
   
7.     temp = Mmin - 1
   
8.     ReDim re(1 To 1)
   
9.     Do Until Mmax - temp <= 0
   
10.        i = i + 1
    
11.        ReDim Preserve re(1 To i)
    
12.        temp = temp + 1
    
13.        If (temp Mod 100) Mod 12 = 1 Then
    
14.             temp = temp + 100 - 12
    
15.         End If
    
16.         re(i) = temp & ""
    
17.     Loop
    
18.     [a6].Resize(UBound(re), 1) = Application.WorksheetFunction.Transpose(re)
    
19. End Sub

复制代码

hwc2ycy

1. Sub myfill()
   
2.     Dim dStart As Date, dEnd As Date
   
3.     Dim strTemp As String
   
4.     Dim arr(1 To 1000, 1 To 1), i As Integer
   
5. 
   
6.     strTemp = Range("b2").Value
   
7.     dStart = CDate(Format(strTemp & "01", "1900/00/00"))
   
8.     strTemp = Range("b3").Value
   
9.     dEnd = CDate(Format(strTemp & "01", "1900/00/00"))
   
10.     Do While dStart <= dEnd
    
11.         i = i + 1
    
12.         arr(i, 1) = Format(dStart, "yymm")
    
13.         dStart = DateAdd("m", 1, dStart)
    
14.     Loop
    
15.     If i Then
    
16.         Range("b6").Resize(i).Value = arr
    
17.         MsgBox "填充完成"
    
18.     Else
    
19.         MsgBox "日期无效"
    
20.     End If
    
21. End Sub

复制代码

evenschen

谢谢大家~~