I have a VBA code in my workbooy 'Service Providers.xlsm' that backs up to an macro free workbook 'Service Providers History.xlsx'.

When I run the code in 'Service Providers.xlsm', it for some reason password protects the sheets in 'Service Providers History.xlsx'.

Is there a way to stop this from happening.

Public Sub ServiceProvidersHistory()

    Application.EnableEvents = False
    Application.ScreenUpdating = Flse
    Dim sourceWB As Workbook
    Dim sourceWS As Worksheet
    Dim historyWB As Workbook
    Dim historyWS As Worksheet
    Dim lastRow As Long
    Dim pasteRow As Long
    
    ' Set source workbook and worksheet
    Set sourceWB = ActiveWorkbook
    Set sourceWS = sourceWB.ActiveSheet
    
    Dim backupNeeded As Boolean
    'backupNeeded = sourceWB.ActiveSheet.Range("J31").Value = ""
    backupNeeded = sourceWB.ActiveSheet.Range("J21").Value = ""
    If backupNeeded Then
        Dim userResponse As VbMsgBoxResult
        userResponse = MsgBox("CURRENT NUMBER OF ENTRIES DO NOT NEED A BACK UP" & vbCrLf & "" & vbCrLf & _
        "Do you still want to back up?", vbQuestion + vbYesNo)
        If userResponse = vbNo Then
            Exit Sub
            End If
            End If
        
    ' Insert today's date in C5 to I5
    Dim currentDate As Date
    currentDate = Date
    ' Unlock Sheet
    sourceWS.Unprotect Password:="edit"
    sourceWS.Range("C5").Value = currentDate
    sourceWS.Range("I5").Value = currentDate
    ' Lock Sheet
    sourceWS.Protect Password:="edit"
   
    ' Find the first empty cell in column I
Dim firstEmptyCell As Range
Set firstEmptyCell = sourceWS.Range("I:I").Find("", LookIn:=xlValues, LookAt:=xlWhole)
Dim dateCell As Range
Set dateCell = firstEmptyCell.Offset(-1, 0)
If Format(dateCell.Value, "dd / mm / yyyy") < Date - 30 Then
    MsgBox "Completed Tasks are recent, wait 30 days before committing to History"
    Application.EnableEvents = True
    Exit Sub
End If

    ' Check if an empty cell is found
    If Not firstEmptyCell Is Nothing Then
        ' Calculate the last row to copy based on the first empty cell in column I
        lastRow = firstEmptyCell.Row - 1
    End If

    ' Copy the range from B5 to the last row in L
    sourceWS.Range("B5:L" & lastRow).Copy

    ' Open the history workbook
        ' USING RELATIVE PATH
Dim filePath As String
filePath = ThisWorkbook.Path & "\Service Providers History.xlsx"
Set historyWB = Workbooks.Open(filePath)

    Application.Wait (Now + TimeValue("0:00:15"))
    ' Select the sheet with the same name as the active sheet in the source workbook
    On Error Resume Next
    Set historyWS = historyWB.Sheets(sourceWS.Name)
    On Error GoTo 0
    
    ' If the sheet doesn't exist, create a new sheet with the same name
    If historyWS Is Nothing Then
        sourceWS.Copy After:=historyWB.Sheets(historyWB.Sheets.count)
        Set historyWS = historyWB.ActiveSheet
        historyWS.Name = sourceWS.Name
          
        'CREATE A NEW SHEET IN HISTORY WITH FORMATING
        
        ' Copy values, formatting and column widths of the range B1:L5
        'sourceWS.Range("B1:L5").Copy
        'historyWS.Range("B1:L5").PasteSpecial xlPasteValuesAndNumberFormats
        'historyWS.Range("B1:L5").PasteSpecial xlPasteColumnWidths

With sourceWS.Range("B1:L5")
            historyWS.Range("B1:L5").Value = .Value
            .Copy
            historyWS.Range("B1:L5").PasteSpecial xlPasteFormats
            historyWS.Range("B1:L5").PasteSpecial xlPasteColumnWidths
            historyWS.Columns("A").ClearContents
            historyWS.Buttons.Delete
            historyWS.Columns("A").ColumnWidth = 5
            historyWS.Rows("6:100").Delete
        End With
        
        ' Prompt user and exit sub
        MsgBox "A NEW HISTORY SHEET WAS CREATED" & vbCrLf & "" & vbCrLf & _
        "Check the sheet Format & Strcture" & vbCrLf & "" & vbCrLf & _
        "Delete the VBA code from the History Sheet" & vbCrLf & "" & vbCrLf & _
        "Close & Save the History Workbook" & vbCrLf & "" & vbCrLf & _
        "Run the History again to archive records.", vbInformation, "HISTORY SHEET"
        Application.EnableEvents = True
        Exit Sub
        
    End If
    
    ' Activate the history workbook, select the history sheet
    historyWB.Activate
    historyWB.Sheets(sourceWS.Name).Select
    
    ' Find the next empty row in the history sheet
    pasteRow = historyWS.Cells(historyWS.Rows.count, "B").End(xlUp).Row + 1
    
    ' Paste the values from the clipboard into the history sheet
    historyWS.Range("B" & pasteRow).PasteSpecial Paste:=xlPasteValues
    
    ' Save and close the history workbook
    historyWB.Save
    historyWB.Close
    
    ' Clear the contents from B6 to the last row in L
    'sourceWS.Range("B6:L" & lastRow).ClearContents
    
' Delete the cells from B6 to the last row in L and move the cells up to row 6
' Unlock Sheet
sourceWS.Unprotect Password:="edit"
    Dim lastCell As Range
    Set lastCell = sourceWS.Range("L" & Rows.count).End(xlUp)
    If lastCell.Row > 6 Then
        ''''''''sourceWS.Range("B6:L" & lastCell.Row).Delete Shift:=xlUp
        Dim clearRange As Range
Set clearRange = sourceWS.Range("B6:L" & lastRow)
clearRange.ClearContents
clearRange.Rows.Delete Shift:=xlShiftUp
    End If
    ' Lock Sheet
sourceWS.Protect Password:="edit"
    
    ' Display a message box
    MsgBox "Completed tasks have been backed up to History"
    
    ' Enable all events
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
End Sub