allow change font while password pretected.

C

Chris

Hi all
I have this sub below that I use, It works very well apart from one small
thing. I would like to have a password in it. Also I need to be able to
change the font colour and make bold etc. I have tryed adding it to the sub
but it wont work, as the sub is now it works but users can go to the
protection in tools and unprotect. If I add a password to the sheet I cant
use the macro. Please help

Regards
Chris




Sub InsertRowsSASDeck()


Dim ar As Long
If Selection.Interior.ColorIndex <> 36 _
Or Selection.Count > 1 Then Exit Sub

ActiveSheet.Unprotect
ar = ActiveCell.Row
Selection.EntireRow.Insert
Cells(ar, "d").Formula = "=a" & ar & "*b" & ar & ""
Cells(ar, "i").Formula = "=a" & ar & "*e" & ar & ""
Cells(ar, "j").Formula = "=a" & ar & "*f" & ar & ""
Cells(ar, "k").Formula = "=a" & ar & "*g" & ar & ""

ActiveSheet.Protect _
DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True, _
AllowFormattingCells:=True, _
AllowFormattingColumns:=True, _
AllowFormattingRows:=True, _
AllowInsertingRows:=False, _
AllowInsertingHyperlinks:=True, _
AllowSorting:=True, _
AllowFiltering:=True, _
AllowUsingPivotTables:=True

End Sub
Sub DeleteRowsSASdeck()
If Selection.Interior.ColorIndex <> 36 Then Exit Sub
ActiveSheet.Unprotect

Selection.EntireRow.Delete

ActiveSheet.Protect _
DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True, _
AllowFormattingCells:=True, _
AllowFormattingColumns:=True, _
AllowFormattingRows:=True, _
AllowInsertingRows:=False, _
AllowInsertingHyperlinks:=True, _
AllowSorting:=True, _
AllowFiltering:=True, _
AllowUsingPivotTables:=True



End Sub
 
D

Dave Peterson

First, you didn't say what you wanted to bold/change font color.

I'd record a macro to get the cells correct and the font color, too.

But you can use:
ActiveSheet.Unprotect password:="YourPasswordHere"
....your code
ActiveSheet.Protect _
password:="YourPasswordHere", _
DrawingObjects:=True, _
 
M

Mike H

Chris,

I'm not sure I understand but you can use a password with VB

ActiveSheet.Unprotect password:="MyPass"

and likewise

ActiveSheet.protect password:="MyPass"
--
Mike

When competing hypotheses are otherwise equal, adopt the hypothesis that
introduces the fewest assumptions while still sufficiently answering the
question.
 
C

Chris

Thanks for that Dave.
I had been trying to change the colours of cell inputs and make bold. We
make the new items Red Bold and black bold for anything one day old then
black standard from then on. So this worked perfectly.
I had tryed to put it in myself the same but I was entering the
Activesheet.Protect_ password on the same line.

Regards
Chris
 
C

Chris

Hi
In the code below, section for amount of rows I would like to have a choise
of how meny rows to insert or delete each time, I have seen part of a code
that gives you this choise but I cant get it to do that. can You help.
Regards
Chris
 
D

Dave Peterson

Option Explicit
Sub InsertRowsSASDeck()

Dim HowManyRows As Long
Dim myRow As Long
Dim myCell As Range

Set myCell = ActiveCell 'single cell
myRow = myCell.Row

If myCell.Interior.ColorIndex <> 36 Then
Exit Sub
End If

HowManyRows = CLng(Application.InputBox(Prompt:="how many rows to insert", _
Type:=1))

If HowManyRows < 1 Then
Exit Sub
End If

'some sort of sanity check to stop typos
If HowManyRows > 50 Then
Exit Sub
End If

With ActiveSheet
.Unprotect
.Cells(myRow, "A").Resize(HowManyRows, 1).EntireRow.Insert
.Cells(myRow, "D").Resize(HowManyRows, 1).Formula _
= "=a" & myRow & "*b" & myRow
.Cells(myRow, "I").Resize(HowManyRows, 1).Formula _
= "=a" & myRow & "*e" & myRow
.Cells(myRow, "J").Resize(HowManyRows, 1).Formula _
= "=a" & myRow & "*f" & myRow
.Cells(myRow, "K").Resize(HowManyRows, 1).Formula _
= "=a" & myRow & "*g" & myRow

.Protect _
DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True, _
AllowFormattingCells:=True, _
AllowFormattingColumns:=True, _
AllowFormattingRows:=True, _
AllowInsertingRows:=False, _
AllowInsertingHyperlinks:=True, _
AllowSorting:=True, _
AllowFiltering:=True, _
AllowUsingPivotTables:=True

End With

End Sub
Sub DeleteRowsSASdeck()

Dim HowManyRows As Long
Dim myRow As Long
Dim myCell As Range

Set myCell = ActiveCell 'single cell
myRow = myCell.Row

If myCell.Interior.ColorIndex <> 36 Then
Exit Sub
End If

HowManyRows = CLng(Application.InputBox(Prompt:="how many rows to delete", _
Type:=1))

If HowManyRows < 1 Then
Exit Sub
End If

'some sort of sanity check to stop typos
If HowManyRows > 50 Then
Exit Sub
End If

With ActiveSheet
.Unprotect
.Cells(myRow, "A").Resize(HowManyRows, 1).EntireRow.Delete
.Protect _
DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True, _
AllowFormattingCells:=True, _
AllowFormattingColumns:=True, _
AllowFormattingRows:=True, _
AllowInsertingRows:=False, _
AllowInsertingHyperlinks:=True, _
AllowSorting:=True, _
AllowFiltering:=True, _
AllowUsingPivotTables:=True
End With

End Sub
 
C

Chris

Thanks again Dave

Perfect.

Dave Peterson said:
Option Explicit
Sub InsertRowsSASDeck()

Dim HowManyRows As Long
Dim myRow As Long
Dim myCell As Range

Set myCell = ActiveCell 'single cell
myRow = myCell.Row

If myCell.Interior.ColorIndex <> 36 Then
Exit Sub
End If

HowManyRows = CLng(Application.InputBox(Prompt:="how many rows to insert", _
Type:=1))

If HowManyRows < 1 Then
Exit Sub
End If

'some sort of sanity check to stop typos
If HowManyRows > 50 Then
Exit Sub
End If

With ActiveSheet
.Unprotect
.Cells(myRow, "A").Resize(HowManyRows, 1).EntireRow.Insert
.Cells(myRow, "D").Resize(HowManyRows, 1).Formula _
= "=a" & myRow & "*b" & myRow
.Cells(myRow, "I").Resize(HowManyRows, 1).Formula _
= "=a" & myRow & "*e" & myRow
.Cells(myRow, "J").Resize(HowManyRows, 1).Formula _
= "=a" & myRow & "*f" & myRow
.Cells(myRow, "K").Resize(HowManyRows, 1).Formula _
= "=a" & myRow & "*g" & myRow

.Protect _
DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True, _
AllowFormattingCells:=True, _
AllowFormattingColumns:=True, _
AllowFormattingRows:=True, _
AllowInsertingRows:=False, _
AllowInsertingHyperlinks:=True, _
AllowSorting:=True, _
AllowFiltering:=True, _
AllowUsingPivotTables:=True

End With

End Sub
Sub DeleteRowsSASdeck()

Dim HowManyRows As Long
Dim myRow As Long
Dim myCell As Range

Set myCell = ActiveCell 'single cell
myRow = myCell.Row

If myCell.Interior.ColorIndex <> 36 Then
Exit Sub
End If

HowManyRows = CLng(Application.InputBox(Prompt:="how many rows to delete", _
Type:=1))

If HowManyRows < 1 Then
Exit Sub
End If

'some sort of sanity check to stop typos
If HowManyRows > 50 Then
Exit Sub
End If

With ActiveSheet
.Unprotect
.Cells(myRow, "A").Resize(HowManyRows, 1).EntireRow.Delete
.Protect _
DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True, _
AllowFormattingCells:=True, _
AllowFormattingColumns:=True, _
AllowFormattingRows:=True, _
AllowInsertingRows:=False, _
AllowInsertingHyperlinks:=True, _
AllowSorting:=True, _
AllowFiltering:=True, _
AllowUsingPivotTables:=True
End With

End Sub
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Password Protect Sheet with formatting allowed 3
Modifying a protect unprotect macro 10
Insert row and copy formulas 5
Qualifying permissions in protect unprotect macro. 3
Sorting a protected worksheet 1
cell locking problem 1
Error in Macro 2003 2
How to extend the life of a variable from one Private Sub routine to another? 1

Top