none
Unable to clear run time error 1004 RRS feed

  • Question

  • Hi I am desperate for help I have not taken basic since high school.  I am creating a gate log for my officers to enter the date and time with just a click and it gets locked and then I need it too unlock for the rest of the columns so that my officers may enter name, visitor name,etc..  that data also needs to be protected once they enter it.  Budget is tight so I have been trying to make it so it can be easier for the officers.

    here is my code any help would be appreciated.  Thanks

    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim r1, r2, MyRange As Range
    Dim IntersectRange As Range
    Set r1 = Range("a2:a21")
    Set r2 = Range("g2:g21")

    Set MyRange = Union(r1, r2)

    Set IntersectRange = Intersect(Target, MyRange)

    If IntersectRange Is Nothing Then
    Exit Sub
    Else
        Target = Format(Now)
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    ActiveSheet.EnableSelection = xllockedCells

        End If

    End Sub
    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Cell As Range
    ActiveSheet.Unprotect Password:=""
    For Each Cell In Target
    If Cell.Value = "" Then
        Cell.Locked = False
        Else
        Cell.Locked = True
            End If
        Next Cell
        ActiveSheet.Protect Password:=""
        
        End Sub

    Friday, October 23, 2015 3:57 AM

All replies

  • Format the required cells in the ranges on the worksheet using Number format so that if you later want to perform maths operations with them then they will work. Using the VBA Format command places the cells in text mode and you cannot add and subtract them or perform other maths operations with them.

    Try the following code. You should not need the Worksheet Change event.


    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
        Dim r1
        Dim r2
        Dim MyRange As Range
        Dim IntersectRange As Range
       
        If Target.Cells.Count <> 1 Then Exit Sub    'Only allow one cell selection
       
        Set r1 = Range("a2:a21")
        Set r2 = Range("g2:g21")
       
        Set MyRange = Union(r1, r2)
       
        Set IntersectRange = Intersect(Target, MyRange)
       
        If IntersectRange Is Nothing Then
            Exit Sub
        Else
            If Target.Value = "" Then
                ActiveSheet.Unprotect Password:=""
                Target = Now
           
                ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
                'ActiveSheet.EnableSelection = xllockedCells   'Incorrect
                ActiveSheet.EnableSelection = xlNoRestrictions
            End If
        End If
       
    End Sub


    Regards, OssieMac



    • Edited by OssieMac Monday, October 26, 2015 3:26 AM
    Friday, October 23, 2015 7:39 AM
  • Thank you so much OssieMac for your help I was able to get the runtime error from coming up I appreciate it.  I just need now for the protection to release once it protects the date and time entry without my officers having to manually unprotect the worksheet.  Also now that I have your ear (lol) how do i now pass this to all worksheets.

    Thank you so much I am just trying to make it easier for my officers.

    Mel

    Monday, October 26, 2015 9:06 PM
  • Hi Mel,

    Not sure that I understand. Do you mean that you only want to protect the date and time and the rest of the worksheet should remain unprotected?

    To add the code to other worksheets just copy the code in the existing worksheets module and then double click the other worksheet name in the VBA project explorer (left column) and paste into that module.


    Regards, OssieMac

    Monday, October 26, 2015 11:09 PM
  • Sorry I want the date and time protected and also the data but after the date and time is entered  and tab to the next cell the message for protection on the sheet comes up in order to enter information in the cell the officer would have to go to review tab and click on unprotect sheet to place the data in that cell.  Basically I need each cell to lock once data is entered and then unlock for the next cell that is blank so that all data is saved and protected once entered.

    Sorry trying to explain it as best as i can


    • Edited by pelmel1968 Tuesday, October 27, 2015 1:12 AM
    Tuesday, October 27, 2015 12:36 AM
  • The following code will lock and protect the cells in MyRange after they have data and the remaining cells on the worksheet will be unlocked.

    What concerns me is what happens if a user inadvertently clicks the wrong cell in the one of the 2 ranges? Currently you do not have a password and the user could unlock the worksheet and correct the error. (ie. delete the incorrect entry and then select the correct cell). If you apply a password and the user does not have access to the password then they will not be able to correct such an error.

    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
        Dim r1
        Dim r2
        Dim MyRange As Range
        Dim IntersectRange As Range
       
        If Target.Cells.Count <> 1 Then Exit Sub    'Only allow one cell selection
       
        Set r1 = Range("a2:a21")
        Set r2 = Range("g2:g21")
       
        Set MyRange = Union(r1, r2)
       
        Set IntersectRange = Intersect(Target, MyRange)
       
        If IntersectRange Is Nothing Then
            Exit Sub
        Else
            If Target.Value = "" Then
                ActiveSheet.Unprotect Password:=""
                ActiveSheet.Cells.Locked = False
                Target = Now
                MyRange.SpecialCells(xlCellTypeConstants).Locked = True
                ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
                ActiveSheet.EnableSelection = xlNoRestrictions
            End If
        End If
    End Sub


    Regards, OssieMac

    Tuesday, October 27, 2015 1:31 AM
  • Hi OssieMac,

    I guess what I am saying is that when I did my code I originally  had this code for the rest of the cells other than a2-a21(date and time entered) and g2-g21 (date and time exited) the other columns are name , visitor names, license plate number. Everything needs to get locked after data is entered in each cell and then unlocked for empty cells for the officer to enter the information I am not to concerned about typos or errors on spelling because as long as the name column (that I am doing as a list drop box) is correct and the plate is correct it will be fine or the officer can just start on another row if they realize their mistake.    Ugh I hope what I am saying makes sense. 

     Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Cell As Range
    ActiveSheet.Unprotect Password:=""
    For Each Cell In Target
    If Cell.Value = "" Then
        Cell.Locked = False
        Else
        Cell.Locked = True
            End If
        Next Cell
        ActiveSheet.Protect Password:=""
        
        End Sub

    Tuesday, October 27, 2015 2:19 AM
  • Try the following and see if it does what you want. Basically it unlocks all cells and then locks the cells that contain either a constant or a formula without the need to loop through cells.

    I have included the Worksheet Change event again.

    I have included Application.EnableEvents together with an error handling routine in case events are disabled and an error occurs that prevents events being re-enabled. The user will get a message that an error has occurred but not where it occurred. You will need to comment out all of the lines "On Error GoTo ReEnableEvents" and then run the code it to get the debugger to stop on the errant line and then use the utility as per the following paragraph.

    At the end of the code I have included a small utility to re-enable events in case it is required. I add it to all of my projects to be used during development. Just position the cursor anywhere within the sub and press F5.

    If you want to work on development of the worksheet without the subs running then just change their name like adding a character to the start or end of the name.

    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
        Dim r1
        Dim r2
        Dim MyRange As Range
        Dim IntersectRange As Range
       
        If Target.Cells.Count <> 1 Then GoTo ReEnableEvents    'Only allow one cell selection
       
        On Error GoTo ReEnableEvents
        Application.EnableEvents = False
       
        Set r1 = Range("a2:a21")
        Set r2 = Range("g2:g21")
       
        Set MyRange = Union(r1, r2)
       
        Set IntersectRange = Intersect(Target, MyRange)
       
        If IntersectRange Is Nothing Then
            GoTo ReEnableEvents
        Else
            If Target.Value = "" Then
                ActiveSheet.Unprotect Password:=""
                ActiveSheet.Cells.Locked = False
                Target = Now
               
                On Error Resume Next
                'SpecialCells errors if no cells of specified type exist
                ActiveSheet.Cells.SpecialCells(xlCellTypeConstants).Locked = True
                ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas).Locked = True
                On Error GoTo 0     'Cancel the error number (if any)
                On Error GoTo ReEnableEvents
               
                ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
                ActiveSheet.EnableSelection = xlNoRestrictions
            End If
        End If
       
    ReEnableEvents:
        If Err.Number <> 0 Then
            MsgBox "Error occurred in Private Sub Worksheet_SelectionChange"
        End If
        Application.EnableEvents = True
       
    End Sub
     
    Private Sub Worksheet_Change(ByVal Target As Range)
       
        On Error GoTo ReEnableEvents
        Application.EnableEvents = False
       
        ActiveSheet.Unprotect Password:=""
        ActiveSheet.Cells.Locked = False
       
        On Error Resume Next
        'SpecialCells errors if no cells of specified type exist
        ActiveSheet.Cells.SpecialCells(xlCellTypeConstants).Locked = True
        ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas).Locked = True
        On Error GoTo 0     'Cancel the error number (if any)
        On Error GoTo ReEnableEvents
       
        ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
        ActiveSheet.EnableSelection = xlNoRestrictions
       
    ReEnableEvents:
        If Err.Number <> 0 Then
            MsgBox "Error occurred in Private Sub Worksheet_Change"
        End If
        Application.EnableEvents = True

    End Sub

    '*****************************************************
    Sub ReEnableEvents()
        'Use this utility to re-enable events.
        Application.EnableEvents = True
    End Sub
    '*****************************************************


    Regards, OssieMac

    Tuesday, October 27, 2015 3:49 AM
  • OMG Thank you so much OssieMac this works perfectly.  It is doing exactly what I need I thank you and my officers thank you..
    Tuesday, October 27, 2015 11:16 PM