日期转天数
将Day函数替换成Year函数则将日期转化为年份。
Sub dateToday() Dim tempCell As Range Selection.Value = Selection.Value For Each tempCell In Selection If IsDate(tempCell) = True Then With tempCell .Value = Day(tempCell) .NumberFormat = "0" End With End If Next tempCell End Sub
工作表字数统计
Sub Get_Word_Count() Dim WordCnt As Long Dim rng As Range Dim S As String Dim N As Long For Each rng In ActiveSheet.UsedRange.Cells '去除左右两边空格 S = Application.WorksheetFunction.Trim(rng.Text) N = 0 If S <> vbNullString Then '去除中间空格 N = Len(S) - Len(Replace(S, " ", "")) + 1 End If WordCnt = WordCnt + N Next rng MsgBox "共有:" & Format(WordCnt, "#,##0") & "个汉字" End Sub
转化为数字格式
本方法将文本格式转化为数字格式,即相当于将文本前的撇号去掉。
Sub goToNumber() Selection.Value = Selection.Value End Sub
公式转数值
其效果相当于格式化粘贴只取数值,也可以通过录制宏实现,但效率肯定不及这个方法。
Sub GSToNumber() Dim MyRange As Range Dim MyCell As Range Set MyRange = Selection For Each MyCell In MyRange If MyCell.HasFormula Then MyCell.Formula = MyCell.Value End If Next MyCell End Sub
插入链接
相当于将选中区域复制为格式,但是会链接到源数据,挺有趣的,你可以试试。
Sub insertPicLink() Selection.Copy ActiveSheet.Pictures.Paste(Link:=True).Select End Sub
自动调整行高列宽
此代码自动调整工作表中的所有行或列。当运行此代码时,它将选择工作表中的所有单元格,并自动调整所有行高或列宽。
Sub 自动调整列宽() Cells.Select Cells.EntireColumn.AutoFit End Sub Sub 自动标准行高() Cells.Select Cells.EntireRow.AutoFit End Sub
取消合并单元格
相当于“主页”选项卡上的取消合并选项,以下代码将取消所选内容中的所有合并单元格,如果需要取消特定范围,可以将selection改成具体范围。
Sub 取消合并() Selection.UnMerge End Sub
突出显示内容错误单元格
本方法将文本格式转化为数字格式,即相当于将文本前的撇号去掉。
Sub 定位错误单元格() Dim rng As Range For Each rng In ActiveSheet.UsedRange If Not Application.CheckSpelling(word:=rng.Text) Then rng.Style = "Bad" End If Next rng End Sub
调整图表大小
此宏代码使所有图表的大小相同。可以通过在宏代码中更改图表的高度和宽度。
Sub 调整图表() Dim i As Integer For i = 1 To ActiveSheet.ChartObjects.Count With ActiveSheet.ChartObjects(i) .Width = 300 .Height = 200 End With Next i End Sub
删除空工作表
检查活动工作簿中的所有工作表,如果工作表为空,则将其删除
Sub 删除空白工作表() Dim Ws As Worksheet On Error Resume Next Application.ScreenUpdating= False Application.DisplayAlerts= False For Each Ws In Application.Worksheets If Application.WorksheetFunction.CountA(Ws.UsedRange) = 0 Then Ws.Delete End If Next Application.ScreenUpdating= True Application.DisplayAlerts= True End Sub
关闭所有工作簿
以下会逐个检查所有工作簿并关闭它们,并在关闭之前进行保存并且提示。
Sub 关闭所有() Dim wbs As Workbook For Each wbs In Workbooks wbs.Close SaveChanges:=True Next wb End Sub
添加到邮件附件
打开邮件默认客户端,并将当前文档作为附件添加到邮件中。
Sub 添加附件() Application.Dialogs(xlDialogSendMail).Show End Sub
文件备份
当前文件的同一目录中保存当前工作簿的备份文件,并添加当前日期到文件名。
Sub 备份文件() ThisWorkbook.SaveCopyAs Filename:=ThisWorkbook.Path & _ "" & Format(Date, "mm-dd-yy") & " " & _ ThisWorkbook.name End Sub
取消隐藏行列
一次性将所有行列取消隐藏。
Sub 取消隐藏() Columns.EntireColumn.Hidden = False Rows.EntireRow.Hidden = False End Sub
突出显示行列
以下代码可以突出显示活动行和列。
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim strRange As String strRange = Target.Cells.Address & "," & _ Target.Cells.EntireColumn.Address & "," & _ Target.Cells.EntireRow.Address Range(strRange).Select End Sub
插入多行
以下代码可以输入要插入的行数,并确保从中选择要插入新行的单元格。如果要在所选单元格之后添加行,将代码中的 xlToUp 修改为为 xlToDown即可。
Sub 插入多行() Dim i As Integer Dim j As Integer ActiveCell.EntireRow.Select On Error GoTo Last i = InputBox("请输入要插入行数", "插入行数") For j = 1 To i Selection.Insert Shift:=xlToUp, CopyOrigin:=xlFormatFromRightorAbove Next j Last: Exit Sub End Sub
取消自动换行
以下代码将取消所有单元格的自动换行设置。
Sub 取消换行() Cells.Select Cells.WrapText = False End Sub
高亮显示重复项
检查您择的每个单元格并突出显示重复值。
Sub 查找重复项() Dim myRange As Range Dim myCell As Range Set myRange = Selection For Each myCell In myRange If WorksheetFunction.CountIf(myRange, myCell.Value) > 1 Then myCell.Interior.ColorIndex = 50 End If Next myCell End Sub
保存为pdf
以下代码将所有工作表保存在单独的PDF文件中。
Sub Excel2pdf() Dimws As Worksheet For Each ws In Worksheets ws.ExportAsFixedFormat xlTypePDF, "c:\" & ws.Name & ".pdf" Next ws End Sub
禁用分页符
以下代码将从所有打开的工作簿中禁用分页符。不影响后续打开的新工作簿。
Sub 禁用分页符() Dim wb As Workbook Dim wks As Worksheet Application.ScreenUpdating = False For Each wb In Application.Workbooks For Each Sht In wb.Worksheets Sht.DisplayPageBreaks = False Next Sht Next wb Application.ScreenUpdating = True End Sub
自动添加序号
以下代码会根据录入的最大序列号自动添加到相应的位置。
Sub 添加序号() Dim i As Integer i = InputBox("Enter Value", "Enter Serial Numbers") For i = 1 To i ActiveCell.Value = i ActiveCell.Offset(1, 0).Activate Next i End Sub
统计未保存工作簿数量
当打开的工作簿数量比较多的时候,可以用下面的代码统计有多少未保存。
Sub 统计未保存工作簿() Dim book As Workbook Dim i As Integer For Each book In Workbooks If book.Saved = False Then i = i + 1 End If Next book MsgBox i End Sub
刷新透视表
当数据发生变化的时候,以下代码可以一次性刷新说有透视表
Sub 刷新透视表() Dim pt As PivotTable For Each pt In ActiveWorkbook.PivotTables pt.RefreshTable Next pt End Sub
图表转图像
以下代码可以将图表以的形式展示。
Sub 图表转图像() ActiveChart.ChartArea.Copy ActiveSheet.Range("A1").Select ActiveSheet.Pictures.Paste.Select End Sub
文本转语音
一行代码搞定语音转换。可以试试效果怎么样
Sub 文本转语音() Selection.Speak End Sub
![](http://www.imitker.com/zb_users/upload/2024/06/20240609223530171794373024225.png)
- 上一篇: Excel中超实用的86种常用VBA写法
- 下一篇: git自动merge脚本-linux版
评论
游客
回复赞一个!http://tzafq.zgystjkgl.com/k/5.html
游客
回复这么经典的话只有楼主能想到!http://s86a.rp233.com
游客
回复好东西,学习学习!http://szcmb.zhujibus.com
游客
回复语言表达流畅,没有冗余,读起来很舒服。http://azo.zhujibus.com
游客
回复我就搞不明白了,看帖回帖能死人么,居然只有我这么认真的在回帖!http://luvc.zjchuzhou.com
游客
回复支持一下,下面的保持队形!http://n2u6k.kbuzuta.cn
游客
回复哥回复的不是帖子,是寂寞!http://www.osyiul.com
游客
回复收藏了,很不错的内容!http://www.zjchuzhou.com
游客
回复东方不败还是灭绝师太啊?http://www.zsykx.com
游客
回复关注一下!http://www.zaazq.com