Sub New_Book()
       Dim New_Wb As Workbook, sh As Worksheet
       Dim nm As Name
'Application.ScreenUpdating = False
       For Each sh In ThisWorkbook.Worksheets
           If New_Wb Is Nothing Then
               sh.Copy
               Set New_Wb = ActiveWorkbook
           Else
               sh.Copy After:=New_Wb.Sheets(Sheets.Count)
           End If
       Next

       For Each sh In New_Wb.Worksheets
           If sh.Name <> "сводный анализ" Then
               sh.UsedRange.Value = sh.UsedRange.Value
           End If
       Next
On Error Resume Next
       For Each nm In New_Wb.Names
           If nm.Name <> "свд" Then
                           nm.Delete
           End If
       Next
On Error GoTo 0
       iPath = ThisWorkbook.Path
           If Not Right$(iPath, 1) = "\" Then iPath = iPath & "\"

Filename = (iPath & Split(ThisWorkbook.Name, ".")(0) & "_" & Format(Date, "DD_MM_YY") & ".xlsm")
'With New_Wb
      New_Wb.SaveAs Filename:=Filename, FileFormat:=52
         
      ' выше все нормально
      ' ниже - хрень
         
     Set New_Wb = Workbooks.Open(Filename)
     a = New_Wb.FullName
'With New_Wb
'    New_Wb.SaveAs Filename:=(iPath & Split(ThisWorkbook.Name, ".")(0) & "_" & Format(Date, "DD_MM_YY") & ".xlsm"), FileFormat:=52
       New_Wb.ChangeLink Name:=ThisWorkbook.Name, NewName:=New_Wb.Name, Type:=xlExcelLinks
          
           New_Wb.Sheets("сводный анализ").PivotTables.Item(1).ChangePivotCache New_Wb. _
           PivotCaches.Create(SourceType:=xlDatabase, SourceData:="свд", Version:= _
           xlPivotTableVersion12)

          
          
       New_Wb.Save
'    End With
           ThisWorkbook.Close False
'Application.ScreenUpdating = True
End Sub