Protected Worksheet Not Working with VB Code

[KMS126]

Hello!

I am trying to update a worksheet that is supposed to be protected for others to use. I unprotected the worksheet, entered my code, protected the worksheet, then saved it to be Macro compatible and now the code doesn't work.

I did not use a password to protect it. Do I need one?

Current code was derived from a post I found on here from a few years ago. I have not worked with VB code before so this is all new to me!:

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Count = 1 Then
Dim Colr As Long, Txt As String
If Target.Address(0, 0) = "A5" Then
Txt = "Parent -- Employer"
ElseIf Target.Address(0, 0) = "A14" Then
Txt = "Parent -- Employer"
ElseIf Target.Address(0, 0) = "A23" Then
Txt = "Parent -- Employer"
ElseIf Target.Address(0, 0) = "A30" Then
Txt = "Parent -- Employer"
ElseIf Target.Address(0, 0) = "A37" Then
Txt = "Parent -- Employer"
ElseIf Target.Address(0, 0) = "A44" Then
Txt = "Parent -- Employer"
ElseIf Target.Address(0, 0) = "A51" Then
Txt = "Income Type"
End If

Application.EnableEvents = False
If Len(Target.Value) = 0 Or Target.Value = Txt Then
Target.Font.ColorIndex = 15
Target.Value = Txt
Target.Font.Bold = False
Else
Target.Font.ColorIndex = 13
Target.Font.Bold = True

End If
Application.EnableEvents = True
End If

End Sub



(Summary: I am trying to have specific cells be light in color until someone types in that cell to add information and have it change colors and be bold).

 

[Joe4]

Welcome to the Board!

If you have protected your worsheet, then you will need to unprotect it at the beginning of you VBA code like this:

ActiveSheet.Unprotect

Then you can re-protect it again at the end of your code like this:

ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

Note that you can get these lines of code simply by using the Macro Recorder and recording yourself protecting/unprotecting the sheet.

 

[KMS126]

Welcome to the Board!

If you have protected your worsheet, then you will need to unprotect it at the beginning of you VBA code like this:

ActiveSheet.Unprotect

Then you can re-protect it again at the end of your code like this:

ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

Note that you can get these lines of code simply by using the Macro Recorder and recording yourself protecting/unprotecting the sheet.

Thank you! This worked perfectly!

Now I need to figure out how to fix it so only certain cells change text color instead of everything turning purple!

 

[Joe4]

Thank you! This worked perfectly!

Now I need to figure out how to fix it so only certain cells change text color instead of everything turning purple!

That is because your second block of code here (unlike your first block) is applied to ALL cells instead of just certain ones:

If Len(Target.Value) = 0 Or Target.Value = Txt Then
Target.Font.ColorIndex = 15
Target.Value = Txt
Target.Font.Bold = False
Else
Target.Font.ColorIndex = 13
Target.Font.Bold = True

End If

Notice how in the first block your are checking the cell addresses so it is only applying it to certain cells.
Your second block of code has no such conditions.

 

[KMS126]

That is because your second block of code here (unlike your first block) is applied to ALL cells instead of just certain ones:

If Len(Target.Value) = 0 Or Target.Value = Txt Then
Target.Font.ColorIndex = 15
Target.Value = Txt
Target.Font.Bold = False
Else
Target.Font.ColorIndex = 13
Target.Font.Bold = True

End If

Notice how in the first block your are checking the cell addresses so it is only applying it to certain cells.
Your second block of code has no such conditions.

Ok that makes sense. I figured it had to do with the second part. Any recommendations on how I can fix it? I only need the specific A cells (from the first part) to change to the bold and ColorIndex 13.

 

[Joe4]

OK, I took some liberties of re-writing/simplifying your code.

See if this does all that you want:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim txt As String
    Dim chk As Boolean

    If Target.CountLarge > 1 Then Exit Sub

    ActiveSheet.Unprotect
    Application.EnableEvents = False
    
    chk = False
    
    Select Case Target.Address(0, 0)
        Case "A5", "A14", "A23", "A30", "A37", "A44"
            If (Target.Value = "Parent -- Employer") Or (Len(Target.Value) = 0) Then
                txt = "Parent -- Employer"
                chk = True
            End If
        Case "A51"
            If (Target.Value = "Income Type") Or (Len(Target.Value) = 0) Then
                txt = "Income Type"
                chk = True
            End If
    End Select
    
    If chk = True Then
        Target.Font.ColorIndex = 15
        Target.Value = txt
        Target.Font.Bold = False
    Else
        Target.Font.ColorIndex = 13
        Target.Font.Bold = True
    End If

    Application.EnableEvents = True
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    
End Sub

 

[KMS126]

OK, I took some liberties of re-writing/simplifying your code.

See if this does all that you want:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim txt As String
    Dim chk As Boolean

    If Target.CountLarge > 1 Then Exit Sub

    ActiveSheet.Unprotect
    Application.EnableEvents = False
   
    chk = False
   
    Select Case Target.Address(0, 0)
        Case "A5", "A14", "A23", "A30", "A37", "A44"
            If (Target.Value = "Parent -- Employer") Or (Len(Target.Value) = 0) Then
                txt = "Parent -- Employer"
                chk = True
            End If
        Case "A51"
            If (Target.Value = "Income Type") Or (Len(Target.Value) = 0) Then
                txt = "Income Type"
                chk = True
            End If
    End Select
   
    If chk = True Then
        Target.Font.ColorIndex = 15
        Target.Value = txt
        Target.Font.Bold = False
    Else
        Target.Font.ColorIndex = 13
        Target.Font.Bold = True
    End If

    Application.EnableEvents = True
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
   
End Sub

Unfortunately it's still changing the font on all the other cells.

(But this code is a lot cleaner and easier to understand, thank you!)

 

[Joe4]

Please show me an example of your sheet/data, and your expected behavior.

MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in

Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.

 

[KMS126]

Calculation Worksheet (Dec 2022).xlsm
	A	B	C	D	E	F	G	H	I
1	UPDATED INCOME CALCULATION SHEET 4/2021
2	Six Weeks Back Date:	____________________________			FID:	____________________________
3
4	WEEK INCOME JOB #1:
5	Parent -- Employer		HOURS	DATE		Self Employed Quarterly Earnings
6						Month/Year	Net Income	Hour/$14.25
7								0.00
8								0.00
9								0.00
10	$0.00	$0.00	0.00				$0.00	0.00
11	Total	Monthy Avg	Week Avg				Monthy Avg	Avg Weekly
12
13	WEEK INCOME JOB #2:
14	Parent -- Employer		HOURS	DATE		Other Income 1:	___________________________________		DATE
15						Monthly	Week	Biweek
16
17
18
19	$0.00	$0.00	0.00
20	Total	Monthy Avg	Week Avg				$0.00	$0.00
21							$0.00	$0.00
22	BI-WEEK INCOME JOB #1:						$0.00	$0.00
23	Parent -- Employer		HOURS	DATE
24
25						Other Income 2:	___________________________________		DATE
26	$0.00	$0.00	0.00			Monthly	Week	Biweek
27	Total	Monthy Avg	Week Avg
28
29	BI-WEEK INCOME JOB #2:
30	Parent -- Employer		HOURS	DATE
31							$0.00	$0.00
32							$0.00	$0.00
33	$0.00	$0.00	0.00				$0.00	$0.00
34	Total	Monthy Avg	Week Avg
35
36	TWICE MONTH INCOME JOB #1:
37	Parent -- Employer		HOURS	DATE		Child Support Paid Out (enter as negative)			DATE
38						Monthly	Week	Biweek
39
40	$0.00	$0.00	0.00
41	Total	Monthy Avg	Week Avg
42
43	TWICE MONTH INCOME JOB #2:						$0.00	$0.00
44	Parent -- Employer		HOURS	DATE			$0.00	$0.00
45							$0.00	$0.00
46
47	$0.00	$0.00	0.00
48	Total	Monthy Avg	Week Avg
49
50	MONTHLY Income:						Net Rental Income		Month
51	Income Type	HOURS	DATE				Total Rents
52							Utilities
53							Mortgage
54							Taxes
55								$0.00
56	MONTHLY INCOME CALCULATION						negative income enter as 0
57	TOTAL GMI			ADJUSTED GMI
58		TAFDC			Explain Other
59	$0.00	Other Income 1			Explain Other
60	$0.00	Other Income 2			Gross Monthly Income
61		Net Rental Income Received		$0.00	Child Support/Alimony Paid
62		Any other Income			TAFDC Rental Allowance
63	$0.00	Monthly Income			Employee Benefits
64	$0.00	Total Gross Monthly Income		$0.00	Total GMI To Deduct
Sheet1

Cell Formulas
Range	Formula
H7:H9	H7	=SUM(G7/4.33)/(14.25)
A10,G43:H43,G31:H31,G20:H20,A19	A10	=SUM(A6:A9)
B10,B19	B10	=SUM(A10/4*4.33)
C10,C19	C10	=SUM(C6:C9)/(4)
G10:H10	G10	=SUM(G7:G9)/(3)
G21,G44,G32	G21	=G20/4
H21,H44,H32	H21	=H20/2
G22,G45,G33	G22	=G21*4.33
H22,H45,H33	H22	=H21*2.17
A26,A47,A40,A33	A26	=SUM(A24:A25)
B26,B33	B26	=SUM(A26/2*2.17)
C26,C47,C40,C33	C26	=SUM(C24:C25)/(4)
B40,B47	B40	=SUM(A40)
H55	H55	=H51-H52-H53-H54
A59	A59	=SUM(F16+G22+H22)
A60	A60	=SUM(F27+G33+H33)
D61	D61	=SUM(F39+G45+H45)
A63	A63	=SUM(B10+B19+B26+B33+B40+B47+A52+G10)
A64	A64	=SUM(A58:A63)+(D64)
D64	D64	=SUM(D58:D63)

Cells with Data Validation
Cell	Allow	Criteria
A5	Any value

Please show me an example of your sheet/data, and your expected behavior.

MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in

Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.