Excel VBA更改单元格值取决于[关闭]旁边的日期

Question

如果当前日期大于我要设置的单元格旁边的日期，我想将单元格值设置为特定文本（仅使用 VBA。例如，今天的日期大于单元格 M15 中的日期，所以我会喜欢在单元格 L15 中写“PASSED”）。我需要为整列设置它。 我必须使用 VBA，因为用户可以删除单元格中的任何公式。

我没有使用 VBA 的经验，我总是试图找到一些我可以根据自己的目的进行编辑的代码示例，但在这种情况下我没有找到任何代码示例。

Answer 1

业余赛事

标题说明了一切。我对结果并不完全满意，但它应该是这样的，但首先......

问题

不清楚如果日期不早于今天该怎么办，因此您可能需要编辑我选择在这些情况下返回 "" 的行。

“主要参与者”是 DateCalc Sub，它在每次重新计算工作表时运行，如果 M 列包含公式，即当您通过“手动”将值添加到单元格中来更改数据时，这就足够了在M 列中，未触发 Calculate 事件，因此我必须添加 Change 事件，该事件将相应地更改 L 列中的值。但是Calculate 事件多次触发Change 事件，因此使用Calculation 属性或多或少成功地抑制了它。

代码

本工作簿

Option Explicit

Private Sub Workbook_Open()
  Sheet1.DateCalc
End Sub

Sheet1

Option Explicit

Private Sub Worksheet_Activate()
  DateCalc
End Sub

Private Sub Worksheet_Calculate()
  DateCalc
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

  Const cSource As Variant = "M"       ' Column Letter/Number
  Const cTarget As Variant = "L"       ' Column Letter/Number
  Const cString As String = "PASSED"   ' Write String
  Const cFirst As Long = 2             ' First Data Row

  If Application.Calculation = xlCalculationManual Then Exit Sub

  If Val(Application.Version) >= 12 Then
    If Selection.Cells.CountLarge > 1 Then Exit Sub
   Else
    If Selection.Cells.Count > 1 Then Exit Sub
  End If

  If Not Intersect(Target, Cells(cFirst, cSource) _
      .Resize(Cells(Rows.Count, cSource).End(xlUp).Row)) Is Nothing Then
    If Target > Date Then
      Target.Offset(0, -1) = cString
     Else
      Target.Offset(0, -1) = ""
    End If
  End If

End Sub

Sub DateCalc()

  Application.Calculation = xlCalculationManual

  Const cSource As Variant = "M"       ' Column Letter/Number
  Const cTarget As Variant = "L"       ' Column Letter/Number
  Const cString As String = "PASSED"   ' Write String
  Const cFirst As Long = 2             ' First Data Row

  Dim i As Long

  For i = cFirst To Cells(Rows.Count, cSource).End(xlUp).Row
    If Cells(i, cSource) > Date Then
      Cells(i, cSource).Offset(0, -1) = cString
     Else
      Cells(i, cSource).Offset(0, -1) = ""
    End If
  Next

  Application.Calculation = xlCalculationAutomatic

End Sub