I'm trying to make an excel where other users can only change a range of cells dependent on an other cell they can change as well (B2). The independent cell B2 is a dropdownlist where they can choose from and can have 4 values. I looked on internet and found examples of independent cells having 2 values. I based myself on this. When I check my code when I didn't protect my worksheet yet it looks like the right cells are locked and unlocked. From the moment I change it to protected sheet I get Run time error 1004:Unable to set locked property of ranged class. I tried to solve it but can't find to fix it. Does someone has an idea where I'm going wrong?
Private Sub Worksheet_Change(ByVal Target As Range)
If Range("B2") = "text 1" Then
Range("F4:Q4").Locked = True
Range("B2").Locked = False
ElseIf Range("B2") = "Text 2" Then
Range("F4:I4").Locked = False
Range("B2").Locked = False
Range("J4:Q4").Locked = True
ElseIf Range("B2") = "Text 3" Then
Range("B4:Q4").Locked = False
Range("B2").Locked = False
ElseIf Range("B2") = "text 4" Then
Range("B4:Q4").Locked = False
Range("B2").Locked = False
End If
End Sub
I was able to solve it with following code
Private Sub Worksheet_Change(ByVal Target As Range)
If Range("B2") = "Text 1" Then
Sheet2.Unprotect Password:="Secret"
Range("F4:Q4").Locked = True
Range("B2").Locked = False
Sheet2.Protect Password:="Secret"
ElseIf Range("B2") = "text 2" Then
Sheet2.Unprotect Password:="Secret"
Range("F4:I4").Locked = False
Range("B2").Locked = False
Range("J4:Q4").Locked = True
Sheet2.Protect Password:="Secret"
ElseIf Range("B2") = "text 3" Then
Sheet2.Unprotect Password:="Secret"
Range("B4:Q4").Locked = False
Range("B2").Locked = False
Sheet2.Protect Password:="Secret"
ElseIf Range("B2") = "text 4" Then
Sheet2.Unprotect Password:="Secret"
Range("B4:Q4").Locked = False
Range("B2").Locked = False
Sheet2.Protect Password:="Secret"
End If
Now I'm trying to put back in code that was also embedded in worksheet_change
If Target.Column = 2 Then
If Target.Validation.Type = 3 Then
Application.EnableEvents = False
Target.Offset(0, 1).ClearContents
End If
End If
exitHandler:
Application.EnableEvents = True
Exit Sub
This gives me error that I have protected sheet. I thought solving it like this.
Sheet2.Unprotect Password:="Secret"
If Target.Column = 2 Then
If Target.Validation.Type = 3 Then
Application.EnableEvents = False
Target.Offset(0, 1).ClearContents
End If
End If
exitHandler:
Application.EnableEvents = True
Exit Sub
Sheet2.Protect Password:="Secret"
If I do this it does no longer erase value next to dropdownlist. Any clue why it no longer does this?
Related
Im not very familiar with VBA code and was hoping someone could help me with this code.
Im trying to replace 3 different ranges with 3 different values.
The current code ive got seems to only execute the first line and the last 2 lines are ignored
Private Sub CommandButton3_Click()
Range("B2, F1, F3:f5, F20, F22:F24") = "Enter Text Here..."
Range("C2, F2, F21") = "Select 1"
Range("C3:C10, B13:B19, B22:B25, A29:D33,F7:F16, F26:F35").ClearContents
End Sub
Any help or direction would be appreciated! Thanks in advance
Heres the whole code;
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
If Me.Range("B56").Value = 0 Then
Dim xsheet As Worksheet
Set xsheet = Sheets("Heroes_list")
If xsheet.Name <> "Definitions" And xsheet.Name <> "fx" And xsheet.Name <> "Needs" Then
xsheet.Range("A2:AC2").Copy
xIntR = xsheet.UsedRange.Rows.Count
xsheet.Cells(xIntR + 1, 1).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
MsgBox "Saved Successfully!"
End If
Application.ScreenUpdating = True
Else
If Me.Range("B56").Value = 1 Then _
MsgBox "Not allowed, please revise costs, conflicts and all fields are filled correctly."
End If
Application.ScreenUpdating = True
End If
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton2_Click()
Application.DisplayAlerts = False
Worksheets("Heroes_list").Copy ' golly im good
With ActiveWorkbook
ChDir "C:\Users\Evane\Documents\Calix\Photoshop_excel_imports\"
.SaveAs Filename:="C:\Users\Evane\Documents\Calix\Photoshop_excel_imports\hero" & ".txt", FileFormat:=xlText, CreateBackup:=False
.Close False
End With
Application.DisplayAlerts = True
MsgBox "Exported successfully!"
End Sub
Private Sub Worksheet_Calculate()
If Me.Range("B52").Value = 1 Then _
MsgBox "The current effect combination for this PRIMARY ATTACK is invalid,Please ensure that if negative effects are listed, the list starts with atleast 1 negative status effect or that the effect list starts at line 1."
End
If Me.Range("B54").Value = 1 Then _
MsgBox "The current effect combination for this SECONDARY ATTACK is invalid,Please ensure that if negative effects are listed, the list starts with atleast 1 negative status effect or that the effect list starts at line 1."
End
If Me.Range("A49").Value > 1 Then _
MsgBox "Element conflict! The same element cannot be listed under both weakness and resistance!"
End
End Sub
Public Sub PasteasValue()
Selection.PasteSpecial Paste:=xlPasteValues
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Range("b56") = 1 Then Sheets("Hero_creation").CommandButton1.BackColor = RGB(255, 0, 0) 'Red!
If Range("b56") = 1 Then Sheets("Hero_creation").CommandButton1.Font.Strikethrough = True 'strikethrough text
If Range("b56") = 0 Then Sheets("Hero_creation").CommandButton1.BackColor = RGB(0, 255, 0) 'Green!
If Range("b56") = 0 Then Sheets("Hero_creation").CommandButton1.Font.Strikethrough = False 'No strik through text
End Sub
'New Code
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.address = "$B$2" Or Target.address = "$F$1" Or Target.address = "$F$20" Or Target.address = "$C$2" Or Target.address = "$F$2" Or Target.address = "$F$3" Or Target.address = "$F$4" Or Target.address = "$F$5" Or Target.address = "$F$21" Or Target.address = "$F$22" Or Target.address = "$F$23" Or Target.address = "$F$24" Or Target.address = "$C$3" Or Target.address = "$C$4" Or Target.address = "$C$5" Or Target.address = "$C$6" Or Target.address = "$C$7" Or Target.address = "$C$8" Or Target.address = "$C$9" Or Target.address = "$C$10" Then
If Target.Value = "" Then ' case a cell was emptied
Let Application.EnableEvents = False
Let Target.Value = "Enter Text Here..."
Let Application.EnableEvents = True
Else ' case a text was entered
With Target.Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
End If
Else
' Target is Not a cell to be acted on
End If
End Sub
Private Sub CommandButton3_Click()
Range("B2, F1, F3:f5, F20, F22:F24") = "Enter Text Here..."
Range("C2, F2, F21") = "Select 1"
Range("C3:C10, B13:B19, B22:B25, A29:D33,F7:F16, F26:F35").ClearContents
End Sub
In your Worksheet_Calculate event, you are missing the If in your Ends which ends up as a End statement, this stops the entire procedure immediately
I have also removed _ after Then.
Full code below:
Private Sub Worksheet_Calculate()
If Me.Range("B52").Value = 1 Then
MsgBox "The current effect combination for this PRIMARY ATTACK is invalid,Please ensure that if negative effects are listed, the list starts with atleast 1 negative status effect or that the effect list starts at line 1."
End If
If Me.Range("B54").Value = 1 Then
MsgBox "The current effect combination for this SECONDARY ATTACK is invalid,Please ensure that if negative effects are listed, the list starts with atleast 1 negative status effect or that the effect list starts at line 1."
End If
If Me.Range("A49").Value > 1 Then
MsgBox "Element conflict! The same element cannot be listed under both weakness and resistance!"
End If
End Sub
I assume Worksheet_Calculate is triggered because you have formula(s) from other cells that are affected by the change so if you do not want that to be triggered, manipulate Application.EnableEvents property:
Private Sub CommandButton3_Click()
Application.EnableEvents = False
Range("B2, F1, F3:f5, F20, F22:F24") = "Enter Text Here..."
Range("C2, F2, F21") = "Select 1"
Range("C3:C10, B13:B19, B22:B25, A29:D33,F7:F16, F26:F35").ClearContents
Application.EnableEvents = True
End Sub
I have some VBA code (below) to hide and show rows based on a cell value, the VBA works when the cell is clicked in and then out however or done manually however there is a formula in the cell i need the VBA to be based on and I have tried a couple of ways but I am not getting any success and cannot get it to refresh and run the VBA. I don't really want or need to have the end user to click in any unnecessary fields - any advice would be greatly appreciated.
Private Sub Worksheet_Change(ByVal Target As Range)
ActiveSheet.Activate
Application.ScreenUpdating = False
On Error Resume Next
If Not Application.Intersect(Range("G20"), Range(Target.Address)) Is Nothing Then
Select Case Target.Value
Case Is = "0":
Rows("27:64").EntireRow.Hidden = True
End Select
End If
If Not Application.Intersect(Range("G20"), Range(Target.Address)) Is Nothing Then
Select Case Target.Value
Case Is = "1":
Rows("27:29").EntireRow.Hidden = False
Rows("31:42").EntireRow.Hidden = False
Rows("52:64").EntireRow.Hidden = False
Rows("43:45").EntireRow.Hidden = True
Rows("46:51").EntireRow.Hidden = True
Rows("30:30").EntireRow.Hidden = True
End Select
If
On Error Resume Next
If Not Application.Intersect(Range("G20"), Range(Target.Address)) Is Nothing Then
Select Case Target.Value
Case Is = "2":
Rows("27:29").EntireRow.Hidden = False
Rows("31:45").EntireRow.Hidden = False
Rows("52:64").EntireRow.Hidden = False
Rows("46:51").EntireRow.Hidden = True
Rows("30:30").EntireRow.Hidden = True
End Select
End If
On Error Resume Next
If Not Application.Intersect(Range("G20"), Range(Target.Address)) Is Nothing Then
Select Case Target.Value
Case Is = "3":
Rows("27:31").EntireRow.Hidden = False
Rows("31:42").EntireRow.Hidden = False
Rows("46:51").EntireRow.Hidden = False
Rows("43:45").EntireRow.Hidden = True
End Select
End If
On Error Resume Next
If Not Application.Intersect(Range("G20"), Range(Target.Address)) Is Nothing Then
Select Case Target.Value
Case Is = "4":
Rows("27:31").EntireRow.Hidden = False
Rows("32:45").EntireRow.Hidden = True
Rows("52:64").EntireRow.Hidden = True
Rows("46:51").EntireRow.Hidden = False
End Select
End If
On Error Resume Next
If Not Application.Intersect(Range("G20"), Range(Target.Address)) Is Nothing Then
Select Case Target.Value
Case Is = "5":
Rows("27:64").EntireRow.Hidden = False
End Select
End If
Application.ScreenUpdating = True
End Sub
I'm gonna assume you are checking the cell G20in order to hide/unhide rows. So we are going to do this:
First change the code in your worksheet object for this:
Option Explicit
Private Sub Worksheet_Calculate()
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
HideRows Me.Range("G20"), Me
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
This will call another procedure which will be contained in a module like this:
Option Explicit
Sub HideRows(CellValue As Long, ws As Worksheet)
With ws
Select Case CellValue
Case 0
.Rows("27:64").EntireRow.Hidden = True
Case 1
.Rows("27:29").EntireRow.Hidden = False
.Rows("31:42").EntireRow.Hidden = False
.Rows("52:64").EntireRow.Hidden = False
.Rows("43:45").EntireRow.Hidden = True
.Rows("46:51").EntireRow.Hidden = True
.Rows("30:30").EntireRow.Hidden = True
Case 2
.Rows("27:29").EntireRow.Hidden = False
.Rows("31:45").EntireRow.Hidden = False
.Rows("52:64").EntireRow.Hidden = False
.Rows("46:51").EntireRow.Hidden = True
.Rows("30:30").EntireRow.Hidden = True
Case 3
.Rows("27:31").EntireRow.Hidden = False
.Rows("31:42").EntireRow.Hidden = False
.Rows("46:51").EntireRow.Hidden = False
.Rows("43:45").EntireRow.Hidden = True
Case 4
.Rows("27:31").EntireRow.Hidden = False
.Rows("32:45").EntireRow.Hidden = True
.Rows("52:64").EntireRow.Hidden = True
.Rows("46:51").EntireRow.Hidden = False
Case 5
.Rows("27:64").EntireRow.Hidden = False
End Select
End With
End Sub
This way you can use the code for multiple worksheets if they are build the same way, you will only need to copy the code from the worksheet object to other worksheets and it will cal the HideRows which will then hide/unhide rows depending on the value of the cell G20 you can change the target on every sheet.
And as for the use of Select Case you can see that you only need one with all your cases for the value.
Following advice from here, Loop through named range list, I have tried to make the following code more efficient with a loop.
Sub Worksheet_Calculate()
Application.EnableEvents = False
Range("in1.1").Rows.EntireRow.Hidden = (Range("in1.1").Cells(1, 1).Value = "No")
Range("in1.2").Rows.EntireRow.Hidden = (Range("in1.2").Cells(1, 1).Value = "No")
Application.EnableEvents = True
End Sub
However, I still get a runtime error of various flavors, and I don't really understand how VBA properties work.
Sub Worksheet_Calculate()
Application.EnableEvents = False
Dim TargetSheetName As String
TargetSheetName = "Input data"
For Each nmdrange In ThisWorkbook.Names
If Range(nmdrange.RefersTo).Parent.Name = TargetSheetName Then
'Loop over benefits
Range(nmdrange).Rows.EntireRow.Hidden = (Range(nmdrange).Cells(1, 1).Value = "No")
End If
Next nmdrange
Application.EnableEvents = True
End Sub
This worked for me:
Sub Worksheet_Calculate()
Dim nmdrange As Name, rng As Range
On Error GoTo haveError
Application.EnableEvents = False
For Each nmdrange In ThisWorkbook.Names
Set rng = Range(nmdrange.RefersTo) '<< set a variable to simplify subsequent code
'you can use Me to refer to the sheet where this code is running
If rng.Parent.Name = Me.Name Then
'Loop over benefits
rng.Rows.EntireRow.Hidden = (rng.Cells(1, 1).Value = "No")
End If
Next nmdrange
haveError:
'## alert if error
If Err.Number <> 0 Then MsgBox "Error" & Err.Description
Application.EnableEvents = True
End Sub
Basically I have created a List box with a total of 4 items. You can select multiple items in this sheet and I will like to make it so that each selection would show hidden rows, while being able to make multiple selections.
Option Explicit
Private Sub ListBox1_Click()
End Sub
Private Sub worksheet_change(ByVal target As Range)
Application.EnableEvents = False
Union(Rows("20:30"), Rows("51:56")).EntireRow.Hidden = True
If Not Application.Intersect(Range("ListBox1"), Range(target.Address)) Is Nothing Then
Select Case target.Value
Case "Asset Transfer"
Rows("20:22").EntireRow.Hidden = False
Case "Fund Lineup"
Rows("27:30").EntireRow.Hidden = False
Case "Plan Merge"
Rows("23:26").EntireRow.Hidden = False
Case "Loans"
Rows("51:56").EntireRow.Hidden = False
End Select
End If
Set target = Range("bulk")
If target.Value = "Yes" Then
Range("C60") = InputBox("Please enter the number of labor hours'")
Range("D60") = InputBox("Enter Percentage Increase'")
End If
Set target = Range("AutoEnrollment")
If target.Value = "Yes" Then
Range("C59") = InputBox("Please enter the number of employees'")
End If
Application.EnableEvents = True
End Sub
I am using the following code to try and take the user to the first available empty row. This is designed to act as a kind of go to the first empty row link.
Code:
'Go Bottom
If Target.Address = "$K$3" Then
Range("A8").End(xlDown).Offset(1, 0).Select
End If
The code selects the last used row but does not scroll the cell into view.
The user still has to scroll down.
Please can someone show me where i am going wrong?
Full Code:
Option Explicit
Option Compare Text
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo Message
ActiveSheet.DisplayPageBreaks = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Go Bottom
If Target.Address = "$K$3" Then
Range("A8").End(xlDown).Offset(1, 0).Select
End If
'Clear Search Box
If Target.Address = "$L$3:$M$3" Then
On Error Resume Next
Target.Cells.Interior.Pattern = xlNone
Target.Cells.Value = ""
SendKeys "{F2}"
Else
If Target.Address <> "$L$3:$M$3" Then
Range("L3").Value = "Search Supplier Name, Number"
End If
End If
Message:
Application.DisplayAlerts = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Message
On Error Resume Next
ActiveSheet.DisplayPageBreaks = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
'Insert Depot Memo Data for user
Dim oCell As Range, targetCell As Range
Dim ws2 As Worksheet
On Error GoTo Message
If Not Intersect(Target, Range("B:B")) Is Nothing Then ' <-- run this code only if a value in column B has changed
If Not GetWb("Depot Memo", ws2) Then Exit Sub
With ws2
For Each targetCell In Target
Set oCell = .Range("J1", .Cells(.Rows.Count, "J").End(xlUp)).Find(What:=targetCell.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not oCell Is Nothing Then
Application.EnableEvents = False
'Set Format of cell
targetCell.ClearFormats
targetCell.Font.Name = "Arial"
targetCell.Font.Size = "10"
targetCell.Font.Color = RGB(128, 128, 128)
targetCell.HorizontalAlignment = xlCenter
targetCell.VerticalAlignment = xlCenter
targetCell.Borders(xlEdgeBottom).LineStyle = xlContinuous
targetCell.Borders(xlEdgeTop).LineStyle = xlContinuous
targetCell.Borders.Color = RGB(166, 166, 166)
targetCell.Borders.Weight = xlThin
targetCell.Offset(0, -1).Value = Now()
targetCell.Offset(0, 1).Value = oCell.Offset(0, 1)
targetCell.Offset(0, 2).Value = oCell.Offset(0, -2)
targetCell.Offset(0, 3).Value = oCell.Offset(0, -7)
Application.EnableEvents = True
End If
Next
End With
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
'Prompt missed on sale
If Not Intersect(Target, Range("N:N")) Is Nothing And ActiveCell.Value = "Issue Complete" Then
If Target.Cells.Count < 8 Then
Dim MSG1 As Variant
MSG1 = MsgBox("Did Item Miss On-Sale?", vbYesNo, "Feedback")
If MSG1 = vbYes Then
Range("O" & ActiveCell.Row).Value = "Yes"
Else
Range("O" & ActiveCell.Row).Value = "No"
End If
Range("P" & ActiveCell.Row).Value = DateDiff("d", CDate(Format(Range("A" & ActiveCell.Row).Value, "dd/mm/yyyy;#")), Date)
End If
End If
If Not Intersect(Target, Range("D" & ActiveCell.Row)) Is Nothing And Target.Value <> "" Then
Call PhoneBook2
End If
'Send Email - Receipt of Issue
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
If Not Intersect(Target, Range("F:F")) Is Nothing Then
If Target.Cells.Count < 8 Then
If Target.Cells.Offset(0, 8).Value = "" Then
Call SendEmail0
End If
End If
End If
'Send Email - Status Change
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
If Not Intersect(Target, Range("N:N")) Is Nothing Then
If Target.Cells.Count < 8 Then
If Target.Cells.Offset(0, 8).Value = "" Then
Call SendEmail
End If
End If
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Message:
Application.DisplayAlerts = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
End Sub
Thanks
Try this...
Application.Goto Range("A8").End(xlDown).Offset(1, 0) , True
Did you try like this:
If Target.Address = "$K$3" Then
Range("A8").End(xlDown).Offset(1, 0).Activate
End If
you can also find the last row and then go one more row like this
Dim lastRowSheetSix As Long
lastRowSheetSix = ThisWorkbook.Worksheets("PrepareEmailTL-RRD").Range("C1").SpecialCells(xlCellTypeLastCell).Row
lastRowSheetSix=lastRowSheetSix+1
lastRowSheetSix.Select or (Activate) as you wish