PDA

View Full Version : Sheet protection and tabs



geoffishere
02-05-2010, 04:10 AM
I am using the following code

Sub Split_Worksheets()
Dim rRange As Range, rCell As Range
Dim wSheet As Worksheet
Dim wSheetStart As Worksheet
Dim strText As String
Sheet3.AutoFilterMode = False
Set rRange = Range("A1", Range("A65536").End(xlUp))

On Error Resume Next
Application.DisplayAlerts = False
Worksheets("UniqueList").Delete

Worksheets.Add().Name = "UniqueList"

With Worksheets("UniqueList")
rRange.AdvancedFilter xlFilterCopy, , _
Worksheets("UniqueList").Range("A1"), True
Set rRange = .Range("A2", .Range("A65536").End(xlUp))
End With
On Error Resume Next
With Sheet3
For Each rCell In rRange
strText = rCell
.Range("A1").AutoFilter 1, strText
Worksheets(strText).Delete

Worksheets.Add().Name = strText

.UsedRange.Copy Destination:=ActiveSheet.Range("A1")
ActiveSheet.Cells.Columns.AutoFit
Next rCell
End With
With Sheet3
.AutoFilterMode = False
.Activate
End With
On Error GoTo 0
Application.DisplayAlerts = True


Worksheets("UniqueList").Delete
End Sub


I want to protect all of the sheets except the master sheet(sheet3). The only problem is that this code creates new sheets every time i run it. Is there i way i can automatically password protect these sheets every time they are created.

Also when the sheets are created it pushes the master tab all the way to the right is there a way of ensuring this sheet tab stays on the far left

many thanks

Geoff

Bob Phillips
02-05-2010, 05:10 AM
Sub Split_Worksheets()
Dim rRange As Range, rCell As Range
Dim wSheet As Worksheet
Dim wSheetStart As Worksheet
Dim strText As String
Dim wb As Workbook

Sheet3.AutoFilterMode = False
Set rRange = Range("A1", Range("A65536").End(xlUp))

On Error Resume Next
Application.DisplayAlerts = False
Worksheets("UniqueList").Delete

Worksheets.Add().Name = "UniqueList"

With Worksheets("UniqueList")
rRange.AdvancedFilter xlFilterCopy, , _
Worksheets("UniqueList").Range("A1"), True
Set rRange = .Range("A2", .Range("A65536").End(xlUp))
End With
On Error Resume Next
With Sheet3
For Each rCell In rRange
strText = rCell
.Range("A1").AutoFilter 1, strText
Worksheets(strText).Delete

'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
Set wb = Worksheets.Add(after:=Worksheets(Worksheets.Count))
wb.Name = strText
wb.Protect "myPassword"
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

.UsedRange.Copy Destination:=ActiveSheet.Range("A1")
ActiveSheet.Cells.Columns.AutoFit
Next rCell
End With
With Sheet3
.AutoFilterMode = False
.Activate
End With
On Error GoTo 0
Application.DisplayAlerts = True


Worksheets("UniqueList").Delete
End Sub