每个循环跳过复选框的 Excel VBA

Question

我在 Excel 中制作的待办事项列表有问题。目前，我正在尝试创建 VBA 代码，每当单元格中的值发生更改时更新单元格内部填充颜色。换言之，F 列包含项目的到期日期。如果该项目当天到期，则整行的颜色应为红色。如果该项目从那时起 30 天以上到期，则它应该是绿色的，并且中间有不同的站点。待办事项清单应该是动态的。 IE。用户可以随时添加新行。因为 VBA 无法知道最后一行数据在哪里，所以我将代码设置为依赖于列表最左侧列中复选框的位置。我会发布一张图片，但我刚刚开始使用 SO，所以我还没有那种能力。本质上，第 2 行有一个标题行，从 B 列开始有 6 列，转到 G 列，“检查、状态、任务、笔记、到期、剩余天数”。

有一个包含 12 个条目的列表。条目 1-11 工作正常，代表一行可以是 11 种不同的可能颜色。第 12 行是从第 11 行拖放的，包含所有功能和复选框。调用 VBA 时第 12 行不会更新。

我的代码使用 For Each 循环遍历列表中的每个复选框，并根据截止日期更新颜色。对于大多数复选框，它都可以正常工作，并且 msgbox 始终位于表明它正在通过循环正常。但是，当我添加新行时，通过选择整行并将其在工作表中向下拖动，VBA 代码仅停止识别新复选框。它可以遍历除新框之外的所有框。我也附上了我的 VBA 代码。如果有人能告诉我如何修复无法识别（不受欢迎）的复选框，我将不胜感激！

检查更新的代码此代码位于 VBA 的 Worksheet1 部分，而不是其他模块中。

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.Volatile True
    Application.ScreenUpdating = False
    Call Checkbox_Due_Color
    Application.ScreenUpdating = True
End Sub

设置范围并充当决策处理程序的代码我认为问题出在此代码的循环中。 MsgBox myCheckboxLoc.Address 不会在最后一个复选框上触发。这位于模块 2 中。

Option Explicit

Sub Checkbox_Due_Color()
'===============================================================
'Determines how to update the color to indicate days left.
'===============================================================
    Application.Volatile True
    Dim myCheckbox As CheckBox
    Dim myCheckboxLoc As Range
    Dim myDaysLeft As Integer
    Dim myCheckboxName As String

    For Each myCheckbox In ActiveSheet.CheckBoxes
            Set myCheckboxLoc = Range(myCheckbox.TopLeftCell.Address & ":" & myCheckbox.TopLeftCell.Offset(0, 5).Address)
            MsgBox myCheckboxLoc.Address
            If IsEmpty(myCheckbox.TopLeftCell.Offset(0, 4)) = True Then
                'MsgBox "IF TRUE"
                myCheckboxLoc.Interior.ColorIndex = xlNone
            Else
                'MsgBox "IF False"
                myDaysLeft = myCheckbox.TopLeftCell.Offset(0, 4).Value - Date
                'MsgBox myDaysLeft
                Call Update_Color(myCheckboxLoc, myDaysLeft)
            End If
    Next myCheckbox
End Sub

确定使用什么颜色的代码 此代码运行良好，为清楚起见包含在内。也位于模块 2 中。

Sub Update_Color(myCheckboxLoc As Range, myDaysLeft As Integer)
'===============================================================
'Change background color of cell related to days left until due.
'===============================================================

    Select Case myDaysLeft
        Case Is <= 0
            myCheckboxLoc.Interior.Color = RGB(255, 0, 0)
        Case 1
            myCheckboxLoc.Interior.Color = RGB(255, 50, 0)
        Case 2
            myCheckboxLoc.Interior.Color = RGB(255, 100, 0)
        Case 3 To 4
            myCheckboxLoc.Interior.Color = RGB(255, 150, 0)
        Case 5 To 6
            myCheckboxLoc.Interior.Color = RGB(255, 200, 0)
        Case 7 To 9
            myCheckboxLoc.Interior.Color = RGB(255, 210, 0)
        Case 10 To 13
            myCheckboxLoc.Interior.Color = RGB(255, 230, 0)
        Case 14 To 20
            myCheckboxLoc.Interior.Color = RGB(255, 255, 0)
        Case 21 To 29
            myCheckboxLoc.Interior.Color = RGB(175, 255, 0)
        Case Else
            myCheckboxLoc.Interior.Color = RGB(0, 255, 0)
        End
    End Select

End Sub

Answer 1

您的代码在 Update_Color 子过程中中断。您不需要在“结束选择”之前放置“结束”。您的案例陈述应如下所示：

 Select Case myDaysLeft
    Case Is <= 0
        myCheckboxLoc.Interior.Color = RGB(255, 0, 0)
    Case 1
        myCheckboxLoc.Interior.Color = RGB(255, 50, 0)
    Case 2
        myCheckboxLoc.Interior.Color = RGB(255, 100, 0)
    Case 3 To 4
        myCheckboxLoc.Interior.Color = RGB(255, 150, 0)
    Case 5 To 6
        myCheckboxLoc.Interior.Color = RGB(255, 200, 0)
    Case 7 To 9
        myCheckboxLoc.Interior.Color = RGB(255, 210, 0)
    Case 10 To 13
        myCheckboxLoc.Interior.Color = RGB(255, 230, 0)
    Case 14 To 20
        myCheckboxLoc.Interior.Color = RGB(255, 255, 0)
    Case 21 To 29
        myCheckboxLoc.Interior.Color = RGB(175, 255, 0)
    Case Else
        myCheckboxLoc.Interior.Color = RGB(0, 255, 0)
End Select

我重新创建了您的工作表，删除该行后一切正常。我还建议您使用“Debug.print”而不是“MsgBox”进行调试。

您还说过“因为 VBA 无法知道最后一行数据在哪里，所以我已将代码设置为依赖于列表最左侧列中复选框的位置。”这不太准确。您可以使用 End 属性找出最后一行数据。像这样：

Sub getTaskRange()

  Dim cell As Range
  Dim taskRange As Range
  'Set the range object dynamically
  Set taskRange = ActiveSheet.Range(Cells(2, "d"), Cells(Rows.Count, "d").End(xlUp))

  'Print the contents of each cell to the immediate window
  For Each cell In taskRange
    Debug.Print cell.Value
  Next cell

End Sub