根据日期解锁特定的行范围

Question

我需要一些帮助来升级我的 VBA 代码。

我尝试找到一个可以根据当前日期解锁特定行的代码。问题是，我不希望解锁所有行的单元格，而只解锁一组特定范围。就像在“B”列中的当前日期一样，解锁的单元格将从（“D”到“K”）； （“M”到“P”）； （“R”到“S”）和（“U”到“V”）。

中间的单元格包含我不希望人们弄乱或错误更改的公式。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Range("B" & Selection.Row).Value <> Date Then
        ActiveSheet.Protect Password:="3827"
        MsgBox "Only today's date needs to be edited!", vbInformation, "REMINDER"
    ElseIf Range("B" & Selection.Row).Value = Date Then
        ActiveSheet.Unprotect Password:="3827"
        ActiveSheet.EnableSelection = xlNoRestrictions
    End If
End Sub

Answer 1

为什么不更进一步呢？只让他们在激活工作表时选择那些列的今天日期所在的行！

Option Explicit

Private Const PWD As String = "3827"
Private Const UNLOCK_COLS As String = "D:K,M:P,R:S,U:V"

Private Sub Worksheet_Activate()
    Dim dToday As Date, oRng As Range, oItem As Variant
    dToday = Date
    With ActiveSheet
        .Unprotect Password:=PWD
        .Cells.Locked = True
        ' Look for row with today's date and unlock the row inside usedrange
        Set oRng = .Columns("B").Find(What:=dToday)
        If Not oRng Is Nothing Then
            For Each oItem In Split(UNLOCK_COLS, ",")
                Intersect(oRng.EntireRow, .Columns(oItem)).Locked = False
            Next
        End If
        .Protect Password:=PWD
        .EnableSelection = xlUnlockedCells
    End With
End Sub

---

使用 Tim Williams 的优化建议，您甚至可以跳过循环：

Option Explicit

Private Const PWD As String = "3827"
Private Const UNLOCK_COLS As String = "D1:K1,M1:P1,R1:S1,U1:V1"

Private Sub Worksheet_Activate()
    Dim dToday As Date, oRng As Range
    dToday = Date
    With ActiveSheet
        .Unprotect Password:=PWD
        .Cells.Locked = True
        ' Look for row with today's date and unlock the specific columns in the row
        Set oRng = .Columns("B").Find(What:=dToday)
        If Not oRng Is Nothing Then oRng.EntireRow.Range(UNLOCK_COLS).Locked = False
        .Protect Password:=PWD DrawingObjects:=False, Contents:=True, Scenarios:=True ' This allows Adding comments
        .EnableSelection = xlUnlockedCells
    End With
End Sub