Excel VBA - 在日历中输入开始和结束日

Question

我目前正在尝试提出如何编写VBA脚本的想法，该脚本将扫描某些列以开始项目的日期，并将日期放在日历中的相应单元格中。为了让事情变得更清楚，我们可以看看它应该是什么样子：

正如您所看到的，日历包含月份以及每个新周开始的日期（星期一）。例如：第4行中的项目从2017年4月10日开始。脚本应该扫描该单元格并用10填充D4。第5行中的项目从5月3日开始，因此它应该用值3填充G5。相同对于所有其他行和结束日期。

到目前为止，我有想法让宏扫描每个单元格并将其与2017年的每个可能条目进行比较（即一年中的每一天）。这看起来有点像这样：

    destiny_row = 1
    For x = 2 To MaxRowList
    If InStr(1, ActiveSheet.Cells(x, 1), "10.04.2017") > 0 Then
        ActiveSheet.Range("$D$" & x).Value = "10"
        destiny_row = destiny_row + 1
    End If
    Next

但是正如你可以想象的那样，这将是一段必须编写的代码，因为你必须为一年中的每一天编写代码，然后将其复制为结束日期，并且它不会非常有效。

有人知道如何以聪明的方式完成这项工作吗？任何帮助表示赞赏。提前谢谢。

EDIT1： 所以，我试图尽可能好地实现评论中提到的内容。以下是我到目前为止的情况：

Sub Example4()
Dim objDate1 As Date
Dim objDate2 As Date
Dim objDate3 As Date
Dim runningVB As Boolean


If IsDate(Cells(4, 1)) = True Then
objDate1 = CDate(Cells(4, 1))
Else
MsgBox ("Invalid Input")
Exit Sub
End If

If IsDate(Cells(2, 4)) = True Then
objDate2 = CDate(Cells(2, 4))
Else
MsgBox ("Invalid Input")
Exit Sub
End If

If IsDate(Cells(2, 5)) = True Then
objDate3 = CDate(Cells(2, 5))
Else
MsgBox ("Invalid Input")
Exit Sub
End If


If objDate1 < objDate2 Then
Cells(4, 3) = objDate1
Else
End If
If objDate1 < objDate2 Then
runningVB = True
Else
End If

If runningVB = True Then
End
Else
End If

If objDate1 < objDate3 Then
Cells(4, 4) = objDate1

Else
End If
If objDate1 < objDate3 Then
runningVB = True
Else
End If

If runningVB = True Then
End
Else
End If


End Sub

到目前为止，我已将其编写为仅用于比较D2和E2，但它有效。有没有更简单的方法去做？有没有更简单的代码？因为这样我仍然需要为每年的每个星期的每个开始日写它。

Answer 1

我希望这会有所帮助。但是您的工作表会有很大的变化

1）如果您想查看其他日期，可以更改[A1] - 绿色突出显示。

2）复制并粘贴以下公式。对于 RED =$A1+COLUMN()-3， BLUE =MID(TEXT(C2,"mmmm"),TEXT(C2,"d"),1)。

3）您可以在各自的列中输入开始日期和结束日期。

并使用此代码。

Sub Example4()

' Setting up the worksheet
Dim wsActive As Worksheet
Set wsActive = ActiveSheet
wsActive.Cells.Interior.Color = 16777215

' Variables we will use to loop through your sheet
Dim iCell As Integer

' Variables we will use to color your sheet
Dim iDistance As Integer
Dim iStart As Integer

With wsActive
  ' Looping through your sheet
  For iCell = 3 To .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
    iStart = .Cells(iCell, 1) - .Cells(1, 1)
    If Not iStart < 0 Then
      iDistance = .Cells(iCell, 2) - .Cells(iCell, 1)
      .Range(.Cells(iCell, iStart + 3), .Cells(iCell, iStart + iDistance + 3)).Interior.Color = 65535 '<~ change this to desired color
        iStart = 0
        iDistance = 0
        GoTo NextItem
      End If
NextItem:
  Next
End With
End Sub