我需要帮助来编写代码以从日期中提取年份和周数。我需要按周分隔订单,而不是在个别日子。我需要获取格式 yy, WW。在 excel 函数中,我可以编写如下内容:
=CONCATENATE(RIGHT(YEAR(P13);2);",";TEXT(WEEKNUM(P13);"00"))
但我不能用 VBA 代码编写它。
我需要帮助来编写代码以从日期中提取年份和周数。我需要按周分隔订单,而不是在个别日子。我需要获取格式 yy, WW。在 excel 函数中,我可以编写如下内容:
=CONCATENATE(RIGHT(YEAR(P13);2);",";TEXT(WEEKNUM(P13);"00"))
但我不能用 VBA 代码编写它。
D = now()
For i = 0 To t - 1
ActiveCell.Offset(0, i) = Application.WorksheetFunction.Right(Year(D + c * 7), 2)) & "," & Application.WorksheetFunction.WeekNum(D + c * 7)
c = c + 1
Next i
数据 - (格式化后)
03.02.2020 - (20,06)
27.12.2019 - (19,52)
27.12.2019 - (19,52)
使用本机 VBA 函数,例如:
Function vbYrWN(dt As Date) As String
vbYrWN = Format(dt, "yy") & _
Application.International(xlDecimalSeparator) & _
Format(Format(dt, "ww"), "00")
End Function
如果要硬编码逗号分隔符,只需替换Application.International(xlDecimalSeparator)
为","
请注意,VBA函数的first day of week
和的默认值与 Excel函数的默认值相同first week of year
Format
WEEKNUM
编辑
根据评论,OP 似乎不想使用 Excel 默认定义的WEEKNUMBER
.
可以使用ISOweeknumber
并且可能避免丢失序列的问题YR,WN
。但是,当 12 月日期确实在下一年的第 1 周时,必须添加一个测试来调整年份。
我建议尝试:
编辑以解决 VBA 日期函数中的错误
year 也将对应于年初/年末的 weeknumber
Option Explicit
Function vbYrWN(dt As Date) As String
Dim yr As Date
If DatePart("ww", dt - Weekday(dt, vbMonday) + 4, vbMonday, vbFirstFourDays) = 1 And _
DatePart("y", dt) > 350 Then
yr = DateSerial(Year(dt) + 1, 1, 1)
ElseIf DatePart("ww", dt - Weekday(dt, vbMonday) + 4, vbMonday, vbFirstFourDays) >= 52 And _
DatePart("y", dt) <= 7 Then
yr = DateSerial(Year(dt), 1, 0)
Else
yr = dt
End If
vbYrWN = Format(yr, "yy") & _
Application.International(xlDecimalSeparator) & _
Format(Format(dt - Weekday(dt, vbMonday) + 4, "ww", vbMonday, vbFirstFourDays), "00")
End Function
附加评论
您可以替换DatePart("ww", dt - Weekday(dt, vbMonday) + 4, vbMonday, vbFirstFourDays)
为Application.WorksheetFunction.IsoWeekNum(dt)
. 我不确定哪种方法更有效,尽管我通常更喜欢在可用时使用本机 VBA 函数代替 Worksheet 函数。
稍微修改一下你的循环代码,它似乎在这里工作正常,用yy,ww
第 2 行中的相应日期填充第 1 行和第 2 行(我添加了第 2 行堡垒以进行错误检查)。不会错过任何几周。
Sub test()
Dim c As Long, i As Long, t As Long
Dim R As Range
Dim D As Date
D = #12/25/2019#
Set R = Range("A1")
R.EntireRow.NumberFormat = "@"
t = 10
c = 0
For i = 0 To t - 1
R.Offset(0, i) = vbYrWN(D + c * 7)
R.Offset(1, i) = D + c * 7
c = c + 1
Next i
End Sub