Rename lots of sheets: VBA Excel

Private Sub cmdOK_Click()
    Dim Naming As String, daBooks As Long, daPath As String
    Dim ActingBook As String
    usrTabs2Books.Hide
   
    daPath = ActiveWorkbook.Path  'Get current path
    ActingBook = ActiveWorkbook.Name
    Application.ScreenUpdating = False
    For daBooks = 1 To Workbooks(ActingBook).Worksheets.Count 'Count Sheets
        If optFront = True Then  'Where to put the naming conv
            Naming = txtNamingConvention.Text & "-" & Sheets(daBooks).Name
        Else
            Naming = Sheets(daBooks).Name & "-" & txtNamingConvention.Text
        End If
        Sheets(daBooks).Select
        Sheets(daBooks).Copy  'Copy the sheet to new workbook
        Application.DisplayAlerts = False 'Turn OFF alerts
        ActiveWorkbook.SaveAs Filename:=daPath & "\" & Naming & ".xls", FileFormat:= _
        xlNormal   'Name it
        ActiveWorkbook.Close  'Close new workbook
        Application.DisplayAlerts = True 'Alerts back ON
    Next
    Application.ScreenUpdating = True
    MsgBox "Completed splitting " & daBooks & " sheets to " & daPath, _
        vbInformation, "Progress"
End Sub