Help With Looping through range and Locking all rows with Values

[professorj]

Hi I have some code that is working as I intended with one minor exception. Upon clicking the userform button the code runs and adds a validation list to a specific column on the worksheets. It also locks all rows on beginning at a specified row down to the last row with data. It locks the desired rows except that it is locking an extra row past the last actual row with data. Any ideas or clues as to the why it is locking that extra row even though the cell with the condition attached to is blank? Below is the code

Private Sub OkButton_Click()
Application.ScreenUpdating = False
Dim Termset As Worksheet
Dim LastRow As Long
LastRow = 5
Dim I As Long
Dim ScheduleA As Workbook
Dim Wksht As Worksheet
Set Wksht = Workbooks(Me.ComboBox1.Value).Worksheets(1)
Dim newsheet As Worksheet
Workbooks(Me.ComboBox1.Value).Activate
Set ScheduleA = Workbooks(Me.ComboBox1.Value)
Set newsheet = Sheets.Add(After:=Sheets(Worksheets.Count), Count:=1, Type:=xlWorksheet)
newsheet.Name = "ActionCodes"
Worksheets("ActionCodes").Range("A1").Value = "A"
Worksheets("ActionCodes").Range("A2").Value = "M"
Worksheets("ActionCodes").Range("A3").Value = "D"
Worksheets("ActionCodes").Range("C1").Value = "A"
Worksheets("ActionCodes").Range("C2").Value = "M"
Worksheets("ActionCodes").Range("C3").Value = "I"
Worksheets("ActionCodes").Range("C4").Value = "D"
Worksheets("ActionCodes").Range("C5").Value = "R"
For Each Termset In ActiveWorkbook.Worksheets
If Termset.Name = "Manufacturer_Catalogue" Then
With Termset.Range("C4:C5000").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=ActionCodes!$C$1:$C$5"
.IgnoreBlank = True
.InCellDropdown = True
End With
ElseIf Termset.Name <> "ActionCodes" Then
With Termset.Range("H6:H5000").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=ActionCodes!$A$1:$A$3"
.IgnoreBlank = True
.InCellDropdown = True
End With
With Termset.Range("N6:N5000").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=ActionCodes!$A$1:$A$3"
.IgnoreBlank = True
.InCellDropdown = True
End With
End If
Next Termset
newsheet.Visible = xlSheetVeryHidden
For Each Termset In ScheduleA.Worksheets
If Termset.Name <> "Manufacturer_Catalogue" And Termset.Name <> "ActionCodes" Then
For I = 5 To LastRow - 1
Next I
With Termset
Do While 1
If Termset.Range("A" & LastRow).Value <> "" Then
LastRow = LastRow + 1
Else
Exit Do
End If

' If last_row = 2000 Then
' MsgBox ("Error in copying rebates")
' End Sub
' End If
Loop

.Cells.Locked = False
.Cells.FormulaHidden = False
.Range("A6:G" & LastRow).Locked = True
.Range("A6:G" & LastRow).FormulaHidden = False
.Range("L6:M" & LastRow).Locked = True
.Range("L6:M" & LastRow).FormulaHidden = False
.Range("Q6:AD" & LastRow).Locked = True
.Range("Q6:AD" & LastRow).FormulaHidden = False
Termset.Protect "567", DrawingObjects:=True, Contents:=True, _
Scenarios:=True, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
AllowFormattingRows:=True, AllowSorting:=True, UserInterfaceOnly:=True
End With

ElseIf Termset.Name = "Manufacturer_Catalogue" Then
With Wksht
Do While 1
If Termset.Range("A" & LastRow).Value <> "" Then
LastRow = LastRow + 1
Else
Exit Do
End If

' If last_row = 2000 Then
' MsgBox ("Error in copying rebates")
' End Sub
' End If
Loop

.Cells.Locked = False
.Cells.FormulaHidden = False
.Range("A4:A" & LastRow).Locked = True
.Range("A4:A" & LastRow).FormulaHidden = False
Termset.Protect "567", DrawingObjects:=True, Contents:=True, _
Scenarios:=True, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
AllowFormattingRows:=True, AllowSorting:=True, UserInterfaceOnly:=True
End With
End If
Next Termset
Application.ScreenUpdating = True
Unload Me
MsgBox ("Termsets Locked")
End Sub

 

[baitmaster]

Does this do what you want? Note, always test unknown code on a COPY of your workbook, make sure you have your work saved and unnecessary files closed!

Option Explicit

Private Sub OkButton_Click()
Dim wsTermset As Worksheet
Dim LastRow As Long: LastRow = 5
Dim ScheduleA As Workbook: Set ScheduleA = Workbooks(Me.ComboBox1.Value)
Dim Wksht As Worksheet: Set Wksht = ScheduleA.Worksheets(1)

' add action codes
Dim newsheet As Worksheet: Set newsheet = Sheets.Add(After:=Sheets(Worksheets.Count), Count:=1, Type:=xlWorksheet)
With newsheet
    .Name = "ActionCodes"
    .Range("A1").Value = "A"
    .Range("A2").Value = "M"
    .Range("A3").Value = "D"
    .Range("C1").Value = "A"
    .Range("C2").Value = "M"
    .Range("C3").Value = "I"
    .Range("C4").Value = "D"
    .Range("C5").Value = "R"
    .Visible = xlSheetVeryHidden
End With

For Each wsTermset In ScheduleA.Worksheets
    
    Select Case wsTermset.Name
        Case "Manufacturer_Catalogue"
            DV wsTermset.Range("C4:C5000"), "=ActionCodes!$C$1:$C$5"
            
            With Wksht
                LastRow = wsTermset.Cells(10000, 1).End(xlUp).Row ' note this is looking at a different worksheet
                
                .Cells.Locked = False
                .Cells.FormulaHidden = False
                .Range("A4:A" & LastRow).Locked = True
                
            End With
        
        Case "ActionCodes"
            ' no action
        
        Case Else
            DV wsTermset.Range("H6:H5000"), "=ActionCodes!$A$1:$A$3"
            DV wsTermset.Range("N6:N5000"), "=ActionCodes!$A$1:$A$3"
            
            With wsTermset
                
                .Cells.Locked = False
                
                LastRow = .Cells(10000, 1).End(xlUp).Row
                
                With Intersect(.Range("A6:G" & LastRow), .Range("L6:M" & LastRow), .Range("Q6:AD" & LastRow))
                    .Locked = True
                End With
                
            End With
            
    End Select
    
    wsTermset.Protect "567", DrawingObjects:=True, Contents:=True, _
        Scenarios:=True, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowSorting:=True, UserInterfaceOnly:=True
Next wsTermset
Unload Me
MsgBox ("Termsets Locked")
End Sub

Sub DV(rng As Range, strFormula As String)
With rng.Validation
    .Delete
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=strFormula
    .IgnoreBlank = True
    .InCellDropdown = True
End With
End Sub

Note, I haven't tested this code so there may be obvious typos in it