Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

Register Log in
  • Congratulations Chris Miller on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Protect Certain Cells in Excel? 2

Status
Not open for further replies.
shelby55

shelby55

Technical User
Jun 27, 2003
1,229
CA
Hello

With help from Skip I've been able to create many worksheets from a single worksheet. Each worksheet is one patient visit of data.

The code is:
Code: 
Sub AbstractData()
Dim r As Range, wsAdd As Worksheet, t As Range, rSEQ_NO As Range, s As Range, mypassword As String, ws As Worksheet

With Sheets("RawData_A")
Set rSEQ_NO = .Rows(1).Find("SEQ_NO")

If Not rSEQ_NO Is Nothing Then
For Each r In .Range(.[A2], .[A2].End(xlDown))


Sheets("Template").Copy After:=Sheets(Sheets.Count)
Set wsAdd = ActiveSheet
wsAdd.Name = .Cells(r.Row, rSEQ_NO.Column).Value
wsAdd.Tab _
.Color = 49407

For Each t In [From]
.Range(.Cells(r.Row, t.Value), .Cells(r.Row, t.Offset(0, 1).Value)).Copy
wsAdd.Range(t.Offset(0, 2).Value).PasteSpecial _
Paste:=xlPasteAll, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False

wsAdd.Range("A5.J80").HorizontalAlignment = xlLeft

Next
Next
End If
End With

End Sub

What I would like to do is have some cells frozen so no data can be entered. I'm not sure if I first unlock the cells in the worksheet "Template" that is being copied and then protect each worksheet after that or not. I've tried to add the code to below the horizontal alignment but I get an error message and the code stops so not sure where I would put this piece of the code.

Any and all help greatly appreciated - thanks.
 
Sort by date Sort by votes

hi,

PROCESS:

Unprotect sheet

Change cell locking

Protect sheet

Skip,

[glasses]Just traded in my old subtlety...
for a NUANCE![tongue]
 
Upvote 0 Downvote
Hi Skip

I added the code:
Code: 
wsAdd.Unprotect
wsAdd.Range("A5.J80").HorizontalAlignment = xlLeft
wsAdd.Cells.Locked = False
wsAdd.Range("C5:H39,F41:H62,K5:P39,N41:P62").Locked = True
wsAdd.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

What I want is to be able to edit the unlocked cells, which I am, but that interferes with the change cell colour on change of information in Column J from Column B:

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim t As Range, rng As Range
    
    Set rng = Intersect(Rows("5:38"), Range([b1], [j1]).EntireColumn)
   
    For Each t In Target
        With t
        
        'is change in column J?
            If Not Intersect(t, rng, Cells(1, "J").EntireColumn) Is Nothing Then
                If t.Value <> Cells(t.Row, "B").Value Then
                    .Interior.Color = 49407
                  Else
                    
                End If
            End If
        End With
    Next
    
    Set rng = Nothing
End Sub

It stops at the line .interior.color = 49407. Why would that be? Thanks.
 
Upvote 0 Downvote


PROCESS:

Unprotect sheet

Change cell locking, values, formatting etc

Protect sheet

Skip,

[glasses]Just traded in my old subtlety...
for a NUANCE![tongue]
 
Upvote 0 Downvote
Hi Skip

I spoke too soon....for the unlocked cells they are editable in terms of changing data in the cell but the lists attached via data validation don't work i.e. the pull down arrow doesn't work.

Why would that be? Thanks.

 
Upvote 0 Downvote
Because the DV cell is locked?

Skip,

[glasses]Just traded in my old subtlety...
for a NUANCE![tongue]
 
Upvote 0 Downvote
It's not from the locked cell range.
 
Upvote 0 Downvote
but the lists attached via data validation don't work i.e. the pull down arrow doesn't work.
Click to expand...
Are you referring to the LISTS or the Data Validation LIST control?

Skip,

[glasses]Just traded in my old subtlety...
for a NUANCE![tongue]
 
Upvote 0 Downvote
Never mind, Skip, it's a problem with my validation tables that weren't working prior to adding this code.

Thanks.
 
Upvote 0 Downvote
Hi

The following code is working as it should to extract data from each row of RawData to a separate worksheet. All cells where there is data are not frozen, all those not requiring any data to be entered are frozen:
Code: 
Sub AbstractData()
Dim r As Range, wsAdd As Worksheet, t As Range, rSEQ_NO As Range, s As Range, myPassword As String, ws As Worksheet

If worksheetexists("1") Then
MsgBox "Abstracts have already been created"

Else

With Sheets("RawData_A")
Set rSEQ_NO = .Rows(1).Find("SEQ_NO")

If Not rSEQ_NO Is Nothing Then
For Each r In .Range(.[A2], .[A2].End(xlDown))


Sheets("Template").Copy After:=Sheets(Sheets.Count)
Set wsAdd = ActiveSheet
wsAdd.Name = .Cells(r.Row, rSEQ_NO.Column).Value
wsAdd.Tab _
.Color = 49407


For Each t In [From]
.Range(.Cells(r.Row, t.Value), .Cells(r.Row, t.Offset(0, 1).Value)).Copy
wsAdd.Range(t.Offset(0, 2).Value).PasteSpecial _
Paste:=xlPasteAll, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False

wsAdd.Unprotect
wsAdd.Range("A5.J80").HorizontalAlignment = xlLeft
wsAdd.Cells.Locked = False
wsAdd.Range("A1:A79,C5:H38,F40:H61,I5:I79,K5:P38,N40:P61,Q5:Q79").Locked = True
wsAdd.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Next
Next
End If
End With

With Sheets("RawData_A")
.Activate
.Visible = xlSheetHidden
End With

With Sheets("RawDataA_Map")
.Activate
.Visible = xlSheetHidden
End With

With Sheets("Template")
.Activate
.Visible = xlSheetHidden
End With

End If
End Sub

Because cells A1 to H79 aren't to be edited anyway, I've decided I wish to expand the freezing of A1 to H79. However, when just making only that change in the code, I get an error at wsAdd.Range("A5.J80").HorizontalAlignment = xlLeft.

I'm thinking Process that you explained but not understanding why this isn't working. I even tried to move the wsAdd.Unprotect further up the code but that didn't work either. Any help greatly appreciated - thanks.
 
Upvote 0 Downvote
Hi

I didn't know if this would help, but on the Template worksheet there is also some code unprotecting and protecting the specific ranges and I did change them to reflect the new range but didn't know if that would have something to do with the other not working.

That code is (which Skip helped with writing):
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim t As Range, rng As Range
    
    Set rng = Union( _
        Intersect(Rows("5:37"), Range([b1], [j1]).EntireColumn), _
        Intersect(Rows("40:60"), Range([b1], [m1]).EntireColumn), _
        Intersect(Rows("63:79"), Range([b1], [p1]).EntireColumn))
        
        
    Me.Unprotect
    Me.Cells.Locked = False
    
    For Each t In Target
        With t
        
        'is change in column J?
            If Not Intersect(t, rng, Cells(1, "J").EntireColumn) Is Nothing Then
                If t.Value <> Cells(t.Row, "B").Value Then
                    .Interior.Color = 49407
                  Else
                    .Interior.ColorIndex = xlColorIndexNone
                End If
            End If
        
       'is change in column K?
        If Not Intersect(t, rng, Cells(1, "K").EntireColumn) Is Nothing Then
                If t.Value <> Cells(t.Row, "C").Value Then
                    .Interior.Color = 49407
                  Else
                    .Interior.ColorIndex = xlColorIndexNone
                End If
            End If
         'is change in column L?
            If Not Intersect(t, rng, Cells(1, "L").EntireColumn) Is Nothing Then
                If t.Value <> Cells(t.Row, "D").Value Then
                    .Interior.Color = 49407
                  Else
                    .Interior.ColorIndex = xlColorIndexNone
                End If
            End If
            
        'is change in column M?
        If Not Intersect(t, rng, Cells(1, "M").EntireColumn) Is Nothing Then
                If t.Value <> Cells(t.Row, "E").Value Then
                    .Interior.Color = 49407
                  Else
                    .Interior.ColorIndex = xlColorIndexNone
                End If
            End If
        
       'is change in column N?
        If Not Intersect(t, rng, Cells(1, "N").EntireColumn) Is Nothing Then
                If t.Value <> Cells(t.Row, "F").Value Then
                    .Interior.Color = 49407
                  Else
                    .Interior.ColorIndex = xlColorIndexNone
                End If
            End If
        
        'is change in column O?
        If Not Intersect(t, rng, Cells(1, "O").EntireColumn) Is Nothing Then
                If t.Value <> Cells(t.Row, "G").Value Then
                    .Interior.Color = 49407
                  Else
                    .Interior.ColorIndex = xlColorIndexNone
                End If
            End If
        
        'is change in column P?
            If Not Intersect(t, rng, Cells(1, "P").EntireColumn) Is Nothing Then
                If t.Value <> Cells(t.Row, "H").Value Then
                    .Interior.Color = 49407
                  Else
                    .Interior.ColorIndex = xlColorIndexNone
                End If
            End If
               
        End With
    Next
        Set rng = Nothing
        
    Me.Range("A1:H79,I5:I79,K5:P38,N40:P61,Q5:Q79").Locked = True
    Me.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    
End Sub

Thanks.

 
Upvote 0 Downvote
A5[highlight],[/highlight]

Skip,

[glasses]Just traded in my old subtlety...
for a NUANCE![tongue]
 
Upvote 0 Downvote
Skip, can you be just a tad more wordy? I changed the current code to be "A5:H79,I5:I79,K5:p38,N40:p61,Q5:Q79" but it stops at PasteSpecial point of the code.

When it stops it has produced the first abstract and not copied any data into B5 to B7 or J5 to J7 (and there is data to do so) BUT added data in B8 and J8 before stopping. The ranges noted above are locked.

Really appreciate your help!
 
Upvote 0 Downvote
P.S.
If I add
Code: 
wsAdd.Unprotect
wsAdd.Cells.Locked = False

to above the "for each t" line then it stops at
Code: 
wsAdd.Range("A5.J80").HorizontalAlignment = xlLeft

Same results as previous as to producing first worksheet, filling in row 8 but not the previous rows and all locking as appropriate.
 
Upvote 0 Downvote
Code: 
wsAdd.Range("A5.J80").HorizontalAlignment = xlLeft
RIGHT in Range you have a PERIOD rather than a COMMA!

Skip,

[glasses]Just traded in my old subtlety...
for a NUANCE![tongue]
 
Upvote 0 Downvote
Rather than a COLON, sorry

Skip,

[glasses]Just traded in my old subtlety...
for a NUANCE![tongue]
 
Upvote 0 Downvote
Hi Skip

I fixed that, thanks, but the code still isn't working. This is what I have so far and it still stops at the horizontalalignment step. It also only fills in B8/J8 but nothing before it.

Thanks.
 
Upvote 0 Downvote
Status
Not open for further replies.

Similar threads

remeng
  • Locked
  • Solved
Run-time error '429': ActiveX component can't create object From Excel to Word
Replies
9
Views
1K
remeng
remeng
sal21
  • Locked
  • Question
scrping in listbox in a web page
Replies
0
Views
443
sal21
sal21
Andrzejek
  • Question
Hyperlinks in Word cut at #
Replies
2
Views
174
Andrzejek
Andrzejek
huiettcm
  • Locked
  • Question
Excel UserForm Window 'Focus' Event Listener 1
Replies
14
Views
583
huiettcm
huiettcm
f0rg3tfu1
  • Locked
  • Question
VBA Error in Excel
Replies
11
Views
519
combo
combo

Part and Inventory Search

Sponsor

Back
Top