Question

我想知道是否可以制作一个vba代码来查找具有以下条件的日期的周数：

星期五是一周的第一天
如果一周包含两个月（例如：2016年5月27日至2016年6月2日），则周数将根据每个月的天数确定。在这种情况下，一周中可能部分的天数更大，因此周数等于5.

我尝试在电子表格中制作解决方案，但我似乎无法弄清楚如何将其全部转换为vba代码。如果有人知道如何做到这一点，我们非常感激。

以下是我对该解决方案的尝试： spreadsheet (green for input) (blue for output) spreadsheet with formulas

Answer 1

这是一个不那么优雅的解决方案

Option Explicit

Sub main2()

    Dim cell As Range
    Dim date1 As Date, date2 As Date
    Dim weeks1 As Long, weeks2 As Long

    With Worksheets("weeks")
        For Each cell In .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
            date1 = cell.Value
            date2 = cell.Offset(, 1).Value
            weeks1 = DateDiff("ww", date1, "01/01/1900", vbFriday)
            weeks2 = DateDiff("ww", dateadd("d", -Day(date1), date1), "01/01/1900", vbFriday)

            If DatePart("m", date1) <> DatePart("m", date2) Then
                If DateDiff("d", date1, dateadd("d", -Day(date2), date2)) >= 3 Then
                    If IsDate(cell.Offset(-1)) Then
                        cell.Offset(, 8) = cell.Offset(-1, 8) + 1
                    Else
                        cell.Offset(, 8) = weeks2 - weeks1
                    End If
                Else
                    cell.Offset(, 8) = 1
                End If
            Else
                If IsDate(cell.Offset(-1)) Then
                    cell.Offset(, 8) = IIf(cell.Offset(-1, 8) > 3, 1, cell.Offset(-1, 8) + 1)
                Else
                    cell.Offset(, 8) = weeks2 - weeks1
                End If
            End If
        Next cell

    End With

End Sub

Answer 2

可能有一个更好的算法，但是这里有一个UDF，给定任何日期，将根据您的规范返回该日期的周数（如果我已正确理解它们）。

您可以根据需要调整您的具体要求

Option Explicit

Function wnMonth(DT As Date)
    Dim dtFF As Date
    Dim dtLF As Date
    Dim lWN As Long

'First and Last Fridays of current month
dtFF = DT + 8 - Day(DT) - Weekday(DT - Day(DT) + 8 - 6)
dtLF = dtFF + 28 + 7 * (Day(dtFF + 28) < Day(dtFF + 21))

If DT >= dtFF And DT < dtLF Then
    lWN = Int((DT - dtFF) / 7) + 1
    If Day(dtFF) > 4 Then
        lWN = lWN + 1
    End If
Else
    If DT < dtFF Then
        If Day(dtFF) > 4 Then
            lWN = 1
        Else
            'First Friday prior month
            dtFF = DateAdd("m", -1, dtFF)
            dtFF = dtFF + 8 - Day(dtFF) - Weekday(dtFF - Day(dtFF) + 8 - 6)

            'Last Friday prior month
            dtLF = dtFF + 28 + 7 * (Day(dtFF + 28) < Day(dtFF + 21))

            'First Friday weeknumber
            If Day(dtFF) > 4 Then
                lWN = 2
            Else
                lWN = 1
            End If

            'Last Friday weeknumber = DT weeknumber
            lWN = lWN + (dtLF - dtFF) / 7
        End If

    Else 'DT > dtLF
    'days left in the month
        If (8 - Day(dtLF + 7)) < 4 Then
           lWN = 1
        Else
            lWN = (dtLF - dtFF) / 7 + IIf(Day(dtFF) > 4, 2, 1)
        End If
    End If
End If

wnMonth = lWN

End Function

具有条件的月份周数

2 个答案: