Private Declare Function CreateFile _
    Lib "kernel32" _
    Alias "CreateFileA" ( _
        ByVal lpFileName As String, _
        ByVal dwDesiredAccess As Long, _
        ByVal dwShareMode As Long, _
        ByRef lpSecurityAttributes As Any, _
        ByVal dwCreationDistribution As Long, _
        ByVal dwFlagsAndAttributes As Long, _
        ByVal hTemplateFile As Long _
    ) As Long
Private Declare Function CloseHandle _
    Lib "kernel32" ( _
        ByVal hObject As Long _
    ) As Long
Sub Макрос1()
'
' Макрос1 Макрос
'

'
    Sheets("Лист2").Select
    ActiveWorkbook.RefreshAll
    Sheets("Лист3").Select
    Range("A1").Select
    ActiveSheet.PivotTables("СводнаяТаблица3").PivotFields("Shipping Order"). _
    ClearAllFilters
    With ActiveSheet.PivotTables("СводнаяТаблица3").PivotFields("Shipping Order")
    .PivotItems("").Visible = False
    .PivotItems("(пусто)").Visible = False
    End With
    Sheets("Лист1").Select
    ActiveWorkbook.RefreshAll
    Dim Wb As Workbook
    Dim WbName As String
    Dim iPath As String
    Dim iFilePath As String
    Set Wb = ActiveWorkbook
    WbName = Wb.FullName
    iPath = ThisWorkbook.Path & "\"
    iFilePath = Left(WbName, InStrRev(WbName, ".") - 1) + " " + Format(Date, "dd/mm/yyyy") + ".xls"
    If Dir(iFilePath) <> "" Then
    MsgBox "Копия файла c датой " & Format(Date, "yyyy/mm/dd") & " в директории " & Chr(13) & iPath$ & " уже существует!", vbExclamation
    Exit Sub
    End If
    Wb.SaveCopyAs iFilePath
    Dim IsSaved As Boolean
    Do Until IsSaved
        hfile = CreateFile(FilePath, &H80000000, &H1, 0, 3, 0, 0)
        IsSaved = hfile <> -1
        CloseHandle hfile
        DoEvents
    Loop
    Workbooks.Open iFilePath
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Sheets("Лист2").Select
    ActiveWindow.SelectedSheets.Delete
    Sheets("Лист3").Select
    ActiveWindow.SelectedSheets.Delete
    Sheets("Лист4").Select
    ActiveWindow.SelectedSheets.Delete
End Sub