Excluding a column from VB script protection - excel

I am new to VB script and only have the least idea about how it works.
With the below code the idea is that the users will be able to edit/ add details to an Excel worksheet but would not able to delete any data without a password. One of the columns is for adding comments and it is not mandatory that each item should always have a comment. The below code will blindly protect the whole sheet but I need to add an exclusion to column N6:N1000. Would someone here please help me to add this exclusion.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sPassCheck As String
Dim rng As Range
Dim sTemp As String
Dim sPassword As String
sPassword = "12345"
sTemp = "You must enter the password to delete data"
'Use to set a single cell if more than one cell is
'in the target range
If Target.Count > 1 Then
Set rng = Target.Cells(1, 1)
Else
Set rng = Target
End If
If rng.Value = "" Then
sPassCheck = InputBox(sTemp, "Delete check!")
Application.EnableEvents = False
If sPassCheck <> sPassword Then Application.Undo
End If
Application.EnableEvents = True
End Sub

This modification should do it
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sPassCheck As String
Dim rng As Range
Dim sTemp As String
Dim sPassword As String
sPassword = "12345"
sTemp = "You must enter the password to delete data"
' Check if target is within Range N6:N1000
If Intersect(Target, Range("N6:N1000")) Is Nothing Then
If Target.Count > 1 Then
Set rng = Target.Cells(1, 1)
Else
Set rng = Target
End If
If rng.Value = "" Then
sPassCheck = InputBox(sTemp, "Delete check!")
Application.EnableEvents = False
If sPassCheck <> sPassword Then Application.Undo
End If
End If
Application.EnableEvents = True
End Sub

Related

Combining 2 Worksheet Change Events in 1 Worksheet

Fairly new to VBA and Macros, and I would need assistance in combining these 2 worksheet events. Both work individually and I haven't found a way to combine them to run.
Macro 1: Automatically updating Timestamp Data Entries
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myTableRange As Range
Dim myDateTimeRange As Range
Dim myUpdatedRange As Range
Set myTableRange = Range("W4:W3000")
If Intersect(Target, myTableRange) Is Nothing Then Exit Sub
Application.EnableEvents = False
Set myDateTimeRange = Range("AF" & Target.Row)
Set myUpdatedRange = Range("AG" & Target.Row)
If myDateTimeRange.Value = "" Then
myDateTimeRange.Value = Now
End If
myUpdatedRange.Value = Now
Application.EnableEvents = True
End Sub
Macro 2: Allowing for multiple selection in Dropdown lists
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xRng As Range
Dim xValue1 As String
Dim xValue2 As String
If Target.Count > 1 Then Exit Sub
On Error Resume Next
Set xRng = Cells.SpecialCells(xlCellTypeAllValidation)
If xRng Is Nothing Then Exit Sub
Application.EnableEvents = False
If Not Application.Intersect(Target, xRng) Is Nothing Then
xValue2 = Target.Value
Application.Undo
xValue1 = Target.Value
Target.Value = xValue2
If xValue1 <> "" Then
If xValue2 <> "" Then
If xValue1 = xValue2 Or _
InStr(1, xValue1, "; " & xValue2) Or _
InStr(1, xValue1, xValue2 & ";") Then
Target.Value = xValue1
Else
Target.Value = xValue1 & "; " & xValue2
End If
End If
End If
End If
Application.EnableEvents = True
End Sub
Any help/guidance would be greatly appreciated.
Thank you!
Create a module and add two subs there:
Option Explicit
Public Sub updateTimestampDataEntries(ByVal c As Range)
'put the code here - using c instead of target
End Sub
Public Sub allowMultipleSelectionDropdown(ByVal c As Range)
'put the code here - using c instead of target
End Sub
Then you can use these subs within your worksheet_events like this
Private Sub Worksheet_Change(ByVal Target As Range)
dim c as Range: set c = Target.Cells(1,1) 'only check the first cell
If Not Application.Intersect(c, rgMyTable) Is Nothing Then
updateTimestampDataEntries c
ElseIf not Application.Intersect(c, rgValidationLists) Is Nothing Then
allowMultipleSelectionDropdown c
End If
End Sub
Private Property Get rgMyTable() as Range
'put your code here
set rgMyTable = ...
End Property
Private Property Get rgValidationLists as range
'put your code here
set rgValidationLists = ...
End Property

VBA : Target.Value, change the cell

I would like to click on E15 and put the value from E16. How can I do that ?
My code is :
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
If Not Intersect(Target, Range("C6")) Is Nothing Then
Call CLICK_BTN_INFOS_CONTRAT
End If
Dim TabRes() As String
If Target.Value = [E15].Value Then
ReDim TabRes(0 To UBound(Split([Target], ",")))
For i = LBound(TabRes) To UBound(TabRes)
TabRes(i) = Split(Split([Target], ",")(i), "-")(1)
MsgBox TabRes(0)
GET_GROUPE_GESTION_CIBLE TabRes(0)
Next i
End If
End Sub
You are using the wrong event handler. In terms of what you ask, see below code:
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, ActiveSheet.Range("E15")) Is Nothing Then
Target.Value = Target.Offset(0,1).Value
'or
'Target.Value = ActiveSheet.Range("E16").Value
'or
'ActiveSheet.Range("E15").Value = ActiveSheet.Range("E16").Value
End If
End Sub
EDIT
After seeing your comments I am editing. If you are selecting from a dropdown then your event handler is correct, i.e. Worksheet_Change(). The below should meet your requirements..
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, ActiveSheet.Range("E15")) Is Nothing Then
Dim inputString As String
Dim stringArray As Variant
Dim argString as String
'store E15 to a string variable
inputString = Target.Value
'create array from string
stringArray = Split(inputString, " ")
'store E16 to variable to pass to function call
argString = Target.Offset(1, 0).Value
'call function
GET_GROUPE_GESTION_CIBLE(argString)
End If
End Sub

Dynamic Search with highlight - Excel VBA

I would like to achieve the following:
In my excel sheet I have a set of data to which I've applied dynamic filtering by creating a "Search box".
The filtering itself works okay, no problems there, however, I would like to further improve it, by highlighting the text (that is entered into the search box) in the filtered rows in red.
I am attaching a screenshot of what I would like to see in the final version.
Any idea how this can be entered into my current code?
As always, any help is greatly appreciated!
Thank you!
Below is the code I use for the dynamic filtering:
Private Sub TextBox1_Change()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If Len(TextBox1.Value) = 0 Then
Sheet1.AutoFilterMode = False
Else
If Sheet1.AutoFilterMode = True Then
Sheet1.AutoFilterMode = False
End If
Sheet1.Range("B4:C" & Rows.Count).AutoFilter field:=1, Criteria1:="*" & TextBox1.Value & "*"
End If
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Consider something like this - Write in a worksheet the following:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target <> Range("a1") Then Exit Sub
SelectAndChange (Target)
End Sub
Private Sub SelectAndChange(strValue As String)
Dim rngCell As Range
Dim rngRange As Range
Dim strLookFor As String
Dim arrChar As Variant
Dim lngCounter As Long
If strValue = vbNullString Then Exit Sub
Application.EnableEvents = False
Set rngRange = Range("E1:E10")
rngRange.Font.Color = vbBlack
strLookFor = Range("A1").Value
For Each rngCell In rngRange
For lngCounter = 1 To Len(rngCell) - Len(strLookFor) + 1
If Mid(rngCell, lngCounter, Len(strLookFor)) = strLookFor Then
rngCell.Characters(lngCounter, Len(strLookFor)).Font.Color = vbRed
End If
Next lngCounter
Next rngCell
Application.EnableEvents = True
End Sub
The values in E1:E10 would be dependent from the value in A1 like this:

Worksheet_change not working when cell content changes via VBA but does manually

I am trying to color the background of all cells in column B whose content has changed via VBA.
The background changes if I manually update the cells but not when it changes via VBA. I can not get why it is not changing with the VBA.
In the worksheet module for the sheet called OriginalData I have
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
Dim nName As String, nEmail As String
Application.EnableEvents = False
For Each c In Target
If c.Column = 2 And Target <> "" Then
c.Interior.Color = RGB(255, 255, 0)
End If
Next c
Application.EnableEvents = True
End Sub
I am updating the Column 2 on OriginalData with
Sub FindReplace_Updated_UnMatched_NAMES_Original_Prepperd_2()
Dim FindValues As Variant
Dim ReplaceValues As Variant
Dim wsFR As Excel.Worksheet
Dim wsTarget As Excel.Worksheet
Dim lRow As Long
Dim i As Long
Sheets("Updated_UnMatched").Select
Set wsFR = ThisWorkbook.Worksheets("Updated_UnMatched")
Set wsTarget = ThisWorkbook.Worksheets("OriginalData")
lRow = wsFR.Range("C" & wsFR.Rows.Count).End(xlUp).Row
FindValues = wsFR.Range("C1:C" & lRow).Value
ReplaceValues = wsFR.Range("D1:D" & lRow).Value
With wsTarget
If IsArray(FindValues) Then
For i = 2 To UBound(FindValues)
.Columns("B:B").Replace FindValues(i, 1), ReplaceValues(i, 1), xlWhole, xlByColumns, False
Next i
Else
End If
End With
End Sub
You likely errored out on Target <> "" and got stuck with Application.EnableEvents = False environment state.
First, go to the VBE's Immediate Windows (Ctrl+G) and enter the command Application.EnableEvents = True. While in the VBE, make this modification to your code for multiple Target cell counts.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
Dim nName As String, nEmail As String
Application.EnableEvents = False
For Each c In Target
If c.Column = 2 And c.Value <> "" Then '<~~ c <> "", not Target <> ""
c.Interior.Color = RGB(255, 255, 0)
End If
Next c
Application.EnableEvents = True
End Sub
That should be enough to get you going.
When there is some errors during event handler execution, it doesn't work properly for next times. You can find and fix the errors and it will work properly.
As a quick fix, you can do these steps:
Add On Error Resume Next at the beginning of Worksheet_Change to
prevent errors make your code stop working.
Save your workbook in a macro enabled format and reopen it enabling
active content.
Run macro and it will work properly.
I tested your code and it worked for me in Excel 2013.
It is strongly recommended to fix your errors instead of hiding them using On Error Resume Next.

Creating a new spreadsheet from a template

I am developing code which creates a copy of a template spreadsheet whenever text is input into any row within column A. The spreadsheet needs to be named after the text entered.
Currently I have the following code, the problem is that it does not name the new spreadsheet after the text I enter.
The code is as below:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsNew As Worksheet
If Target.Cells.Count > 1 Then Exit Sub
On Error Resume Next
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
Set wsNew = Sheets(Target.Text)
If wsNew Is Nothing Then
Worksheets("Template").Copy After:=Worksheets(Worksheets.Count)
End If
'name new sheet code here
End If
End Sub
Like this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsNew As Worksheet
If Target.Cells.Count > 1 Then Exit Sub
On Error Resume Next
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
Set wsNew = Sheets(Target.Text)
If wsNew Is Nothing Then
Worksheets("Template").Copy After:=Worksheets(Worksheets.Count)
End If
'name new sheet
Worksheets(Worksheets.Count).Name = Target.Text
End If
End Sub
Edit:
User could empty the cell in A1:A10 which will create new tab called "Template (2)". You should also do check:
If Len(Target.Cells.Text) = 0 Then Exit Sub
I'd suggest something like this to create the sheet based on the template with the desired name - but after testing and cleansing the proposed sheet name first for invalid characters
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsNew As Worksheet
Dim strSht As String
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
On Error Resume Next
Set wsNew = Sheets(Target.Text)
On Error GoTo 0
If wsNew Is Nothing Then
If ValidSheetName(Target.Value) Then
strSht = Target.Value
Else
strSht = CleanSheetName(Target.Value)
End If
End If
Worksheets("Template").Copy After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = strSht
End If
End Sub
string cleaning code 1
Function ValidSheetName(strIn As String) As Boolean
Dim objRegex As Object
Set objRegex = CreateObject("vbscript.regexp")
objRegex.Pattern = "[\<\>\*\\\/\?|]"
ValidSheetName = Not objRegex.test(strIn)
End Function
string cleaning code 2
Function CleanSheetName(strIn As String) As String
Dim objRegex As Object
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Global = True
.Pattern = "[\<\>\*\\\/\?|]"
CleanSheetName = .Replace(strIn, "_")
End With
End Function

Resources