这些Excel vba源码，值得收藏

日期转天数

将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