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

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

1 个答案: