Неделя Количество месяца с условиями

Question

Я хотел бы знать, если это возможно, чтобы сделать код VBA, чтобы найти номер недели даты с этими условиями:

1. пятницу является первым днем ​​недели

2. Если неделя состоит из двух месяцев (например: с 27 мая 2016 года по 2 июня 2012 года), номер недели будет определяться количеством дней в каждом месяце. В этом случае количество дней в мае часть недели больше так неделю число равно 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