Dim sh As Worksheet, shp As Shape
On Error Resume Next
Set sh = Worksheets("" & Day(Date))
On Error GoTo 0
If sh Is Nothing Then
MsgBox "当天日期命名的工作表不存在！"
Exit Sub
End If
Application.ScreenUpdating = False
Application.DisplayAlerts = False
sh.Copy
With ActiveSheet.UsedRange
.Value = .Value
End With
For Each shp In ActiveSheet.Shapes
shp.Delete
Next
ActiveWorkbook.Close True, CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & sh.Name & ".xls"
Application.ScreenUpdating = True
MsgBox "保存完毕"