Forum Discussion

Shaun_B's avatar
Shaun_B
Copper Contributor
Feb 19, 2025

Excel VBA Object Variable or With Block Variable Not Set Error

Hello!

I'm trying to figure out where I'm going wrong with my code. Basically I want my code to decide what protections to initiate and how to proceed based on the data in column C on the 'LOA' tab. My table starts at A8 (headers) and is dynamic. My code should be allowing user entry from C9 to last row and only allowing users to edit columns A-B & H-O if there is data selected in Column C for that row. I had to adjust some of the ranges and that's where I started receiving the error. My original code allowed users to edit the headers because there was data in C8 so I tried to update the code to prevent that.

My current code is below:

 

Private Sub Workbook_Open()
    Dim ws As Worksheet
    Dim wsRef As Worksheet
    Dim lastRow As Long
    Dim lastRowRef As Long
    
    ' Set worksheet references
    Set ws = ThisWorkbook.Sheets("LOA")
    Set wsRef = ThisWorkbook.Sheets("References")
    
    ' Unprotect workbook and sheets
    ThisWorkbook.Unprotect "123456"
    ws.Unprotect "123456"
    wsRef.Unprotect "123456"
    
    ' Sort data on LOA sheet
    lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
    ws.Sort.SortFields.Clear
    ws.Sort.SortFields.Add Key:=ws.Range("C8:C" & lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ws.Sort
        .SetRange ws.Range("A8:O" & lastRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    ' Set up data validation for Employee Name
    lastRowRef = wsRef.Cells(wsRef.Rows.Count, "A").End(xlUp).Row
    With ws.Range("C9:C" & lastRow).Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=References!$A$2:$A$" & lastRowRef
    End With
    
    ' Set formulas for columns D-G
    ws.Range("D9:D" & lastRow).Formula = "=VLOOKUP(C9,References!$A$2:$G$" & lastRowRef & ",2,FALSE)"
    ws.Range("E9:E" & lastRow).Formula = "=VLOOKUP(C9,References!$A$2:$G$" & lastRowRef & ",3,FALSE)"
    ws.Range("F9:F" & lastRow).Formula = "=VLOOKUP(C9,References!$A$2:$G$" & lastRowRef & ",4,FALSE)"
    ws.Range("G9:G" & lastRow).Formula = "=VLOOKUP(C9,References!$A$2:$G$" & lastRowRef & ",5,FALSE)"
    
    ' Find the last row with data in column C
    lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
    
    ' Set the range for column C
    Set dataRange = ws.Range("C9:C" & lastRow)
    
    ' Loop through each cell in column C
    For Each cell In dataRange
        If Not IsEmpty(cell) Then
            ' Unlock corresponding cells in A, B, and H-O
            ws.Range("A" & cell.Row & ":B" & cell.Row).Locked = False
            ws.Range("H" & cell.Row & ":O" & cell.Row).Locked = False
        Else
            ' Lock corresponding cells in A, B, and H-O
            ws.Range("A" & cell.Row & ":B" & cell.Row).Locked = True
            ws.Range("H" & cell.Row & ":O" & cell.Row).Locked = True
        End If
    Next cell
    
    ws.Range("C9:C" & lastRow).Locked = False
    
    ' Protect LOA sheet
    ws.Protect "123456", UserInterfaceOnly:=True, AllowFiltering:=True, AllowSorting:=True
    
    ' Protect References sheet
    wsRef.Protect "123456"
    
    ' Protect workbook
    ThisWorkbook.Protect "123456"
End Sub

Option Explicit

Private Const WARNING_MESSAGE As String = "Warning: You are attempting to {0} data." & vbNewLine & _
    "That is not allowed in this spreadsheet. Please press 'ESC' to return to your work."

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ws As Worksheet
    Dim lastRow As Long
    On Error GoTo ErrorHandler
    
    lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
    If Not Intersect(Target, Me.Range("C9:C" & lastRow)) Is Nothing Then
        Application.EnableEvents = False
        Me.Unprotect "123456"
        
        UpdateCellLockStatus Target
        
        Me.Protect "123456", UserInterfaceOnly:=True, AllowFiltering:=True, AllowSorting:=True
    End If

ExitSub:
    Application.EnableEvents = True
    Exit Sub

ErrorHandler:
    MsgBox "An error occurred: " & Err.Description, vbCritical, "Error"
    Resume ExitSub
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Application.CutCopyMode = False Then
        Select Case Application.CutCopyMode
            Case xlCut
                ShowWarningMessage "cut"
            Case xlCopy
                ShowWarningMessage "copy"
        End Select
    End If
End Sub

Private Sub UpdateCellLockStatus(ByVal Target As Range)
    Dim cell As Range
    Dim affectedRange As Range
    
    For Each cell In Intersect(Target, Me.Range("C9:C" & lastRow))
        Set affectedRange = Union(Me.Range("A" & cell.Row & ":B" & cell.Row), _
                                  Me.Range("H" & cell.Row & ":O" & cell.Row))
        
        affectedRange.Locked = (cell.Value = "")
    Next cell
End Sub

Private Sub ShowWarningMessage(ByVal action As String)
    MsgBox Replace(WARNING_MESSAGE, "{0}", action), vbExclamation + vbOKOnly, "Data Modification Warning"
End Sub

Private Sub Worksheet_Change_Paste(ByVal Target As Range)
    If Not Application.CutCopyMode = False Then
        ShowWarningMessage "paste"
    End If
End Sub

Option Explicit

Sub AddNewRowToTable()
    
    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim table_object_row As ListRow
    
    ' Set references to the worksheet and table
    Set ws = ThisWorkbook.Worksheets("LOA")  ' Replace "Sheet1" with your sheet name
    Set tbl = ws.ListObjects(1)  ' Replace "Table1" with your table name

    ' Unprotect workbook and sheets
    ws.Unprotect "123456"
    
    Set table_object_row = tbl.ListRows.Add
    table_object_row.Range(1, 1).Value = ""
    
    ' Protect LOA sheet
    ws.Protect "123456", UserInterfaceOnly:=True, AllowFiltering:=True, AllowSorting:=True
End Sub

 

My old code that worked is below:

 

Private Sub Workbook_Open()
    Dim ws As Worksheet
    Dim wsRef As Worksheet
    Dim lastRow As Long
    Dim lastRowRef As Long
    
    ' Set worksheet references
    Set ws = ThisWorkbook.Sheets("LOA")
    Set wsRef = ThisWorkbook.Sheets("References")
    
    ' Unprotect workbook and sheets
    ThisWorkbook.Unprotect "123456"
    ws.Unprotect "123456"
    wsRef.Unprotect "123456"
    
    ' Sort data on LOA sheet
    lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
    ws.Sort.SortFields.Clear
    ws.Sort.SortFields.Add Key:=ws.Range("C9:C" & lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ws.Sort
        .SetRange ws.Range("A9:AL" & lastRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    ' Set up data validation for Employee Name
    lastRowRef = wsRef.Cells(wsRef.Rows.Count, "A").End(xlUp).Row
    With ws.Range("C9:C" & lastRow).Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=References!$A$2:$A$" & lastRowRef
    End With
    
    ' Set formulas for columns D-G
    ws.Range("D9:D" & lastRow).Formula = "=VLOOKUP(C9,References!$A$2:$G$" & lastRowRef & ",2,FALSE)"
    ws.Range("E9:E" & lastRow).Formula = "=VLOOKUP(C9,References!$A$2:$G$" & lastRowRef & ",3,FALSE)"
    ws.Range("F9:F" & lastRow).Formula = "=VLOOKUP(C9,References!$A$2:$G$" & lastRowRef & ",4,FALSE)"
    ws.Range("G9:G" & lastRow).Formula = "=VLOOKUP(C9,References!$A$2:$G$" & lastRowRef & ",5,FALSE)"
    
    ' Find the last row with data in column C
    lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
    
    ' Set the range for column C
    Set dataRange = ws.Range("C1:C" & lastRow)
    
    ' Loop through each cell in column C
    For Each cell In dataRange
        If Not IsEmpty(cell) Then
            ' Unlock corresponding cells in A, B, and H-AL
            ws.Range("A" & cell.Row & ":B" & cell.Row).Locked = False
            ws.Range("H" & cell.Row & ":AL" & cell.Row).Locked = False
        Else
            ' Lock corresponding cells in A, B, and H-AL
            ws.Range("A" & cell.Row & ":B" & cell.Row).Locked = True
            ws.Range("H" & cell.Row & ":AL" & cell.Row).Locked = True
        End If
    Next cell
    
    ws.Range("C9:C" & lastRow).Locked = False
    
    ' Protect LOA sheet
    ws.Protect "123456", UserInterfaceOnly:=True, AllowFiltering:=True, AllowSorting:=True
    
    ' Protect References sheet
    wsRef.Protect "123456"
    
    ' Protect workbook
    ThisWorkbook.Protect "123456"
End Sub

Option Explicit

Private Const WARNING_MESSAGE As String = "Warning: You are attempting to {0} data." & vbNewLine & _
    "That is not allowed in this spreadsheet. Please press 'ESC' to return to your work."

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo ErrorHandler
    
    If Not Intersect(Target, Me.Range("C:C")) Is Nothing Then
        Application.EnableEvents = False
        Me.Unprotect "123456"
        
        UpdateCellLockStatus Target
        
        Me.Protect "123456", UserInterfaceOnly:=True, AllowFiltering:=True, AllowSorting:=True
    End If

ExitSub:
    Application.EnableEvents = True
    Exit Sub

ErrorHandler:
    MsgBox "An error occurred: " & Err.Description, vbCritical, "Error"
    Resume ExitSub
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Application.CutCopyMode = False Then
        Select Case Application.CutCopyMode
            Case xlCut
                ShowWarningMessage "cut"
            Case xlCopy
                ShowWarningMessage "copy"
        End Select
    End If
End Sub

Private Sub UpdateCellLockStatus(ByVal Target As Range)
    Dim cell As Range
    Dim affectedRange As Range
    
    For Each cell In Intersect(Target, Me.Range("C:C"))
        Set affectedRange = Union(Me.Range("A" & cell.Row & ":B" & cell.Row), _
                                  Me.Range("H" & cell.Row & ":AL" & cell.Row))
        
        affectedRange.Locked = (cell.Value = "")
    Next cell
End Sub

Private Sub ShowWarningMessage(ByVal action As String)
    MsgBox Replace(WARNING_MESSAGE, "{0}", action), vbExclamation + vbOKOnly, "Data Modification Warning"
End Sub

Private Sub Worksheet_Change_Paste(ByVal Target As Range)
    If Not Application.CutCopyMode = False Then
        ShowWarningMessage "paste"
    End If
End Sub

Option Explicit

Sub AddNewRowToTable()
    
    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim table_object_row As ListRow
    
    ' Set references to the worksheet and table
    Set ws = ThisWorkbook.Worksheets("LOA")  ' Replace "Sheet1" with your sheet name
    Set tbl = ws.ListObjects(1)  ' Replace "Table1" with your table name

    ' Unprotect workbook and sheets
    ws.Unprotect "123456"
    
    Set table_object_row = tbl.ListRows.Add
    table_object_row.Range(1, 1).Value = ""
    
    ' Protect LOA sheet
    ws.Protect "123456", UserInterfaceOnly:=True, AllowFiltering:=True, AllowSorting:=True
End Sub

 

I'm also trying to add code that will delete all of the data in a row (without removing data validations or formatting) when the data in Column C is deleted. I tried the following code, but I wasn't sure how to implement it.

 

Option Explicit

Private Const WARNING_MESSAGE_DEL As String = "Warning: You are attempting to delete data in Column C." & vbNewLine & _
    "This action will clear the entire row. Do you want to proceed?"
    
Private Sub Worksheet_BeforeDelete(ByVal Target As Range, Cancel As Boolean)
    Dim intersectRange As Range
    
    ' Check if the deletion involves Column C
    Set intersectRange = Intersect(Target, Me.Columns("C"))
    
    If Not intersectRange Is Nothing Then
        If MsgBox(WARNING_MESSAGE_DEL, vbExclamation + vbYesNo, "Deletion Warning") = vbNo Then
            Cancel = True
        End If
    End If
End Sub

Private Sub ClearRowExceptColumnC(ByVal rowNumber As Long)
    ' Clear cells to the left of Column C
    Me.Range("A" & rowNumber & ":B" & rowNumber).ClearContents
    
    ' Clear cells to the right of Column C
    Me.Range("D" & rowNumber & ":" & Me.Cells(rowNumber, Columns.Count).Address).ClearContents
End Sub

 

I'm very much a novice when it comes to VBA, but I love the customizability and am trying to learn more. If you have any other advice it would be very much appreciated!

3 Replies

  • Could you attach a small sample workbook demonstrating the problem (without sensitive data), or if that is not possible, make it available through OneDrive, Google Drive, Dropbox or similar?

    • Shaun_B's avatar
      Shaun_B
      Copper Contributor

      Good morning! I fixed that error, but now I'm having an error with a different section of my code. There is a section on the worksheet module to prompt the user when they attempt to delete data in Column C (starting in C9 to lastrow), but I'm having a issue with the undo function. It deletes the row just fine when I select 'Yes', but when I select 'Cancel' it gives me 'Run-time error '1004': Method 'Undo' of object '_Application' failed'. Is there a different method I could use or am I using '.undo' incorrectly? The specific piece of code is below (starts at 24) and the Google Drive is located here.

       

      Option Explicit
      
      Private Const WARNING_MESSAGE As String = "Warning: You are attempting to {0} data." & vbNewLine & _
          "That is not allowed in this spreadsheet. Please press 'ESC' to return to your work."
      
      Private Sub Worksheet_Change(ByVal Target As Range)
          Dim lastRow As Long
          Dim intersectRange As Range
          Dim YesNo As VbMsgBoxResult
          On Error GoTo ErrorHandler
          
          lastRow = Cells(Rows.Count, "C").End(xlUp).Row
          Set intersectRange = Intersect(Target, Me.Range("C9:C" & lastRow))
          
          If Not Intersect(Target, Me.Range("C9:C" & lastRow)) Is Nothing Then
              Application.EnableEvents = False
              Me.Unprotect "123456"
              
              UpdateCellLockStatus Target
              
              Me.Protect "123456", UserInterfaceOnly:=True, AllowFiltering:=True, AllowSorting:=True
          End If
      
          If Not intersectRange Is Nothing Then
              If IsEmpty(Target) Then ' Content was deleted
                  YesNo = MsgBox("Warning: You are attempting to delete data in Column C." & vbNewLine & _
                                 "This action will clear the entire row. Do you want to proceed?", vbOKCancel)
                  If YesNo = vbOK Then ' If OK clicked
                      With Application
                          .ScreenUpdating = False
                          .EnableEvents = False
                              Target.EntireRow.Delete ' Delete data in Column C
                          .ScreenUpdating = True
                          .EnableEvents = True
                      End With
                  ElseIf YesNo = vbCancel Then ' If Cancel clicked
                      With Application
                          .EnableEvents = False
                              .Undo
                          .EnableEvents = True
                      End With
                  End If
              End If
          End If
          
      ExitSub:
          Application.EnableEvents = True
          Exit Sub
          
      ErrorHandler:
          MsgBox "An error occurred: " & Err.Description, vbCritical, "Error"
          Resume ExitSub
      
      End Sub

       

Resources