VBA常用程序——每个表都应该有

Sub 复制位图() Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap End Sub

Sub 复制打印() Range("Print_Area").CopyPicture Appearance:=xlScreen, Format:=xlBitmap End Sub

Sub 清除图片() For Each shp In ActiveSheet.Shapes If shp.Type = 13 Then shp.Delete Next shp End Sub

Sub 取消筛选(Optional ob) '用于避免筛选导致清理残留 If IsMissing(ob) Then Set ob = ActiveSheet.Cells ob.AutoFilter Field:=1 ob.AutoFilter End Sub

Function 路径文件全名(Optional path) '包括拓展名 '空参数等同ActiveWorkbook.Name If IsMissing(path) Then path = ActiveWorkbook.FullName 路径文件全名 = Mid(path, InStrRev(path, "") 1, Len(path)) End Function

Function 路径文件名(Optional path) '不包括拓展名 '也可以用于去掉全名的拓展名 If IsMissing(path) Then path = ActiveWorkbook.FullName 路径文件名 = Mid(path, InStrRev(path, "") 1, InStrRev(path, ".") - InStrRev(path, "") - 1) End Function

Function 上级文件夹(Optional path) '不包括最后的,如需要请加 &"" '也可以用于获取路径文件夹名，空参数等同ActiveWorkbook.path If IsMissing(path) Then path = ActiveWorkbook.FullName 上级文件夹 = Left(path, InStrRev(path, "") - 1) End Function

Sub 关闭功能() '关闭一些功能加快 VBA 宏的运行速度 ' On Error Resume Next '出错继续运行 ' Application.DisplayAlerts = False '禁用警告信息 ' Application.DisplayAlerts = True '启用警告信息 Application.ScreenUpdating = False '禁用屏幕更新 Application.DisplayStatusBar = False '禁用状态栏 Application.Calculation = xlCalculationManual '切换到手动计算-4135，如果中途需要计算时用Calculate Application.EnableEvents = False '禁用事件 ActiveSheet.DisplayPageBreaks = False '禁用本表分页符 End Sub

Sub 开启功能() '开启关闭的功能，调试中断可运行开启功能 Application.ScreenUpdating = True '启用屏幕更新 Application.DisplayStatusBar = True '启用状态栏 Application.StatusBar = False '恢复状态栏 Application.Calculation = xlCalculationAutomatic '切换到自动计算-4105 Application.EnableEvents = True '启用事件 'ActiveSheet.DisplayPageBreaks = displayPageBreaksState '启用本表分页符 End Sub

Function 立即窗口清屏() VBA.SendKeys "^{g}" VBA.SendKeys "^{a}" VBA.SendKeys "{del}" End Function