Private Sub CommandButton1_Click()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim ws2 As Worksheet
    Static intI As Integer
    
    On Error GoTo HandleErr
       
    Set wb = Application.Workbooks.Add
    Set ws = ThisWorkbook.Worksheets("Лист2")
    
    ws.Copy After:=wb.Worksheets(wb.Worksheets.Count)
    
    For Each ws2 In wb.Worksheets
        If ws2.Name <> "Лист2" Then
            Application.DisplayAlerts = False
            ws2.Delete
            Application.DisplayAlerts = True
        End If
    Next
    
    intI = intI +  1 
    wb.SaveAs "D:\1\" & intI & ".xls"
    
ExitHere:
    Exit Sub

HandleErr:
    Select Case Err.Number
        Case  1004 
            intI = intI +  1 
            Resume
        Case Else
            MsgBox Err.Number & ": " & Err.Description
            Resume ExitHere
    End Select
End Sub