Option Explicit
Public fso As Object

Sub Сохранить_файлы()
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim Application_Calculation As XlCalculation
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    CloseEmptyWb
    Dim arr As Variant
    arr = ThisWorkbook.Sheets("данные").ListObjects("Подрядчики").ListColumns("Фамилия").DataBodyRange.Value
    
    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
        If arr(ya, 1) <> "" Then
            JobSheet arr(ya, 1)
        End If
    Next
    
    Application.Calculation = Application_Calculation
End Sub

Private Sub JobSheet(ByVal familia As String)
    Dim shSource As Worksheet
    Set shSource = ThisWorkbook.Sheets("акт")
    
    shSource.Range("L7").Value = familia
    shSource.UsedRange.Calculate
    shSource.Copy
        
    Dim shTarget As Worksheet
    Set shTarget = ActiveSheet
    Dim wb As Workbook
    Set wb = shTarget.Parent
    
    shTarget.UsedRange.Value = shTarget.UsedRange.Value
    
    DeleteShapes shTarget
    
    Dim sFull As String
    Dim sName As String
    sName = fso.GetBaseName(ThisWorkbook.Name)
    sName = sName & " " & familia
    ReplaceSymbols sName
    sName = sName & ".xlsx"
    
    sFull = ThisWorkbook.Path & "\" & sName
    
    On Error Resume Next
    Workbooks(sName).Close False
    Kill sFull
    Err.Clear
    wb.SaveAs Filename:=sFull, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    If Err = 0 Then wb.Close False
    On Error GoTo 0
End Sub

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub

Private Sub ReplaceSymbols(ss As String)
    Dim vv As Variant
    For Each vv In Array("\", "/", ":", "*", "?", """", "<", ">", "|", "[", "]") '[] недопустимые только в имени листа
        ss = Replace(ss, vv, " ")
    Next
    ss = Trim(ss) 'Пробел в конце строки не распознаётся файловой системой.
End Sub

Private Sub DeleteShapes(sh As Worksheet)
    Dim sp As Button
    For Each sp In sh.Buttons
        sp.Delete
    Next
End Sub

Sub SaveSheet()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With ActiveSheet
  .Copy After:=Worksheets("акт")
  .Name = "Новый_Акт"
  .DrawingObjects.Delete
  With .UsedRange
    .Value = .Value
  End With
  .Move
End With
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & Application.PathSeparator & "Акт.xls", FileFormat:=xlWorkbookNormal
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub