VBA Small Amendment

Rob_010101

Board Regular
Joined
Jul 24, 2017
Messages
198
Office Version
  1. 365
Platform
  1. Windows
Hello,

I have the below piece of code which moves a row of data to another sheet within the workbook, based on the value from a data validation list. The code works perfectly.

However, the sheet it moves the data from has a lot of formulas in it and people who use the sheet keep accidentally overwriting the formulas. I would usually protect the sheet with the formulas to prevent this but the protection seems to stop the VB code working.

Is it possible to modify the below code to unprotect the sheet with a password, complete the original action and then re-lock it using the same password and with the below protection options?

1665045975169.png


VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
 
  Dim fromRow%
  Dim archiveRow%
  Dim strMatch As String
  Dim wsTarget As Worksheet   'sheet to move data to
  Dim blnMove As Boolean      'whether to move data or not
  Dim blnOnlyValues As Boolean   'determine if it´s the arvjice
 
  If Target.Cells.Count > 1 Then Exit Sub

  If Not Application.Intersect(Target, Range("S2:S1500")) Is Nothing Then 'amend this range address to your
    blnOnlyValues = False
    Select Case UCase(Target.Value)       'as you have given both "closed" and "Closed"
      Case "CLOSED"
        Set wsTarget = ThisWorkbook.Worksheets("Archived Absence")
        blnMove = True
        blnOnlyValues = True
      Case "PHASED RETURN"
        Set wsTarget = ThisWorkbook.Worksheets("Phased Return")
        blnMove = True
        blnOnlyValues = True
      Case "LTS"
        Set wsTarget = ThisWorkbook.Worksheets("Long Term")
        blnMove = True
      Case Else
        blnMove = False
    End Select
    If blnMove Then
       'section of code is taken from your posting
      fromRow = ActiveCell.Row
      With wsTarget     'only change made here
        If .FilterMode Then
          strMatch = "match" & Replace("(2,1/(a:a>""""),1)", "a:a", .AutoFilter.Range.Cells(1).EntireColumn.Address(0, 0, 1, 1))
          archiveRow = Evaluate(strMatch) + 1
        Else
          archiveRow = wsTarget.Cells(wsTarget.Rows.Count, 1).End(3).Row + 1
        End If
      End With
Range(Cells(fromRow, 1), Cells(fromRow, 20)).Copy wsTarget.Cells(archiveRow, 1)
With wsTarget                                                                     '<-- added
    .Range(.Cells(archiveRow, 1), .Cells(archiveRow, 20)).FormatConditions.Delete '<-- added
End With                                                                          '<-- added
If blnOnlyValues Then wsTarget.Cells(archiveRow, 1).Resize(1, 20).Value = Cells(fromRow, 1).Resize(1, 20).Value
Application.EnableEvents = False      '<-- added
Rows(fromRow).EntireRow.Delete
Application.EnableEvents = True       '<-- added
Set wsTarget = Nothing
    End If
  End If

End Sub

Kind Regards
 

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
VBA Code:
Me.Protect Password:="zzz"


VBA Code:
  Me.Unprotect Password:="zzz"
 
Upvote 0
VBA Code:
Me.Protect Password:="zzz"


VBA Code:
  Me.Unprotect Password:="zzz"
Thanks very much,

I got this code from the forum, having very little knowledge of how to work with VB code.

If I may ask, where do I insert the two lines above? I'm assuming at the beginning and end respectively?

Kind Regards
 
Upvote 0

Forum statistics

Threads
1,223,157
Messages
6,170,420
Members
452,325
Latest member
BlahQz

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top