Unlocking Cells

[Jared_Jones_23]

Hello I am trying to unlock a certain range of cells based on a value in another cell and then protect the sheet for the locked cells. After I run the macro everything in my loop becomes unlocked rather than just the specified range. Any suggestions will be appreciated.
Thank you,
Jared

Dim text2 as string
text2="MLC"
For r = 20 To lastRow
If Cells(r, 18) = text2 Then
Range(Cells(r, 55), Cells(r, lastCol)).Locked = False
End If
Next r

Range(Cells(20, 29), Cells(lastRow, lastCol)).Select 'protects data
ActiveSheet.Protect ("macro"), AllowInsertingRows:=True

 

[MrKowz]

Where is lastCol defined? I don't see it Dimmed or defined anywhere.

 

[Jared_Jones_23]

Sorry it is defined in the code I just did not include it in the section i pasted.

 

[MrKowz]

Can you please include your entire code? What you pasted looks perfectly fine to me.

 

[Jared_Jones_23]

Sub Macro_SAM()
Dim lastRow, lastCol As Integer
Dim myarray() As Variant
Dim rCell As Range
Dim iloop As Integer
Dim txt, text2 As String
Dim c As Long

With Application
.EnableEvents = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

Sheets("Data").Unprotect ("macro") 'unprotects whole sheet

Call Macro_1
Call Macro_3

With ActiveSheet
lastRow = .Cells(.Rows.count, "D").End(xlUp).Row
lastCol = .Cells(20, .Columns.count).End(xlToLeft).Column
End With

text2 = "MLC"

For r = 20 To lastRow
If Cells(r, 18) = text2 Then
Range(Cells(r, 55), Cells(r, lastCol)).Locked = False
End If
Next r
Range(Cells(20, 29), Cells(lastRow, lastCol)).Select 'protects data
ActiveSheet.Protect ("macro"), AllowInsertingRows:=True

count = 0
count2 = 0

For Each rCell In Range(Cells(20, 1), Cells(lastRow, 1)) 'Checks rows with incorrect data
If rCell.Interior.ColorIndex = 4 Then
count2 = count2 + 1
ReDim Preserve myarray(iloop)
myarray(iloop) = rCell.Row
iloop = iloop + 1
End If
Next rCell

If count2 > 0 Then
For c = LBound(myarray) To UBound(myarray)
txt = txt & myarray(c) & vbCrLf
Next c
MsgBox ("Please Correct Data in the Following Rows: ") & txt
End If
With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

 

[MrKowz]

Try this code, it will lock those cells where the condition is not met.

Sub Macro_SAM()
Dim lastRow As Long, lastCol As Long
Dim myarray() As Variant
Dim rCell As Range
Dim iloop As Integer
Dim txt As String, text2 As String
Dim c As Long

With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

Sheets("Data").Unprotect ("macro") 'unprotects whole sheet

Call Macro_1
Call Macro_3

With ActiveSheet
    lastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
    lastCol = .Cells(20, .Columns.Count).End(xlToLeft).Column
End With

text2 = "MLC"

For r = 20 To lastRow
    If Cells(r, 18) = text2 Then
        Range(Cells(r, 55), Cells(r, lastCol)).Locked = False
[B][COLOR=Red]    Else
        Range(Cells(r, 55), Cells(r, lastCol)).Locked = True[/COLOR][/B]
    End If
Next r
Range(Cells(20, 29), Cells(lastRow, lastCol)).Select 'protects data
ActiveSheet.Protect ("macro"), AllowInsertingRows:=True

Count = 0
count2 = 0

For Each rCell In Range(Cells(20, 1), Cells(lastRow, 1)) 'Checks rows with incorrect data
    If rCell.Interior.ColorIndex = 4 Then
        count2 = count2 + 1
        ReDim Preserve myarray(iloop)
        myarray(iloop) = rCell.Row
        iloop = iloop + 1
    End If
Next rCell

If count2 > 0 Then
    For c = LBound(myarray) To UBound(myarray)
        txt = txt & myarray(c) & vbCrLf
    Next c
    MsgBox ("Please Correct Data in the Following Rows: ") & txt
End If

With Application
    .EnableEvents = True
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With
End Sub

 

[Jared_Jones_23]

Thank you very much it works great!

 

[MrKowz]

Thank you very much it works great!

Cheers! Glad we were able to track down the problem. Thank you for the feedback!

 

[Jared_Jones_23]

I have another question just wondering if you had any suggestions. Right now the data I am using is stored in a table. When its like this it will not let me copy a row and insert it but if you convert it to a range it works fine. However, once I convert it to a range and run the following macro it deletes a row of information that isn't even in the range thats being altered. It happens in the red text and that is using the cells from row 20 down but my information in row 19 gets erased. Any ideas? thank you

Sub Macro_1() 'Highlights empty mandatory cells
Dim myarray As Variant
Dim lastRow, lastCol As Integer
With Application
.EnableEvents = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
myarray = Array(1, 2, 7, 8, 12, 14, 15, 16, 18, 20, 21, 22, 23, 24, 25, 26) 'mandatory columns
count = 0

With ActiveSheet
lastRow = .Cells(.Rows.count, "D").End(xlUp).Row 'Finds last row and column
lastCol = .Cells(20, .Columns.count).End(xlToLeft).Column
End With
Range(Cells(20, 1), Cells(lastRow, lastCol)).Interior.ColorIndex = 0
For r = 20 To lastRow 'Finds empty mandatory cells and colors them
If Cells(r, 4) <> "" Then
For Each xVal In myarray
If Cells(r, xVal) = "" Then
Cells(r, xVal).Interior.ColorIndex = 28
count = count + 1
End If
Next xVal
End If
Next r
With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub