Excel技能树系列10：拿来就用的宏代码17条

这里有一部分拿来就用的宏代码，可以先观看目录看看是否有需要的。

1. 取消隐藏所有的行和列
2. 对所有合并单元格取消合并
3. 以当前时间为名字保存工作簿
4. 将每张工作表单独保存为一个PDF文件
5. 将工作簿保存为一个PDF文件
6. 保护所有带公式的单元格
7. 给选定区域交替高亮显示，增加可读性
8. 高亮显示所有带评论的单元格
9. 在选定区域内高亮显示所有的空单元格
10. 重新调整所有的图表为同样大小
11. 给当前工作簿创建备份
12. 一次性关掉所有打开的工作簿
13. 将选中区域保存为PDF文件
14. 删除选中单元格区域的空格字符
15. 将选定区域内的空白单元格以0填充
16. 合并多个工作表
17. 合并多个Excel文件

对于Excel来说，只需要按住Alt + F11就可以打开宏编辑器，然后点击插入->模块菜单，将代码复制进去，适当修改就可以使用了。对于WPS表格需要升级为专业版本，并且安装VBA支持才可以运行宏代码。

---

\'取消隐藏所有的行和列
Sub UnhideRowsColumns()
Columns.EntireColumn.Hidden = False
Rows.EntireRow.Hidden = False
End Sub

\'对所有合并单元格取消合并
Sub UnmergeAllCells()
ActiveSheet.Cells.UnMerge
End Sub

\'以当前时间为名保存Excel文件
Sub SaveWorkbookWithTimeStamp()
Dim timestamp As String
timestamp = Format(Date, "dd-mm-yyyy") & "_" & Format(Time, "hh-ss")
    ThisWorkbook.SaveAs "目录绝对路径" & timestamp
End Sub

\'将每张工作表单独保存为一个PDF文件
Sub SaveWorkshetAsPDF()
Dim ws As Worksheet
For Each ws In Worksheets
ws.ExportAsFixedFormat xlTypePDF, "目录绝对路径" & ws.Name & ".pdf"
Next ws
End Sub

\'将动作不保存为一个PDF文件
Sub SaveWorkshetAsPDF()
ThisWorkbook.ExportAsFixedFormat xlTypePDF, "目录绝对路径" & ThisWorkbook.Name & ".pdf"
End Sub

\'保护所有带公式的单元格
Sub LockCellsWithFormulas()
With ActiveSheet
   .Unprotect
   .Cells.Locked = False
   .Cells.SpecialCells(xlCellTypeFormulas).Locked = True
   .Protect AllowDeletingRows:=True
End With
End Sub

\'在选中区域的每一行下面插入一个空行
Sub InsertAlternateRows()
Dim rng As Range
Dim CountRow As Integer
Dim i As Integer
Set rng = Selection
CountRow = rng.EntireRow.Count
For i = 1 To CountRow
ActiveCell.EntireRow.Insert
ActiveCell.Offset(2, 0).Select
Next i
End Sub

\'给选定区域高亮交替显示，增加表格可读性
Sub HighlightAlternateRows()
Dim Myrange As Range
Dim Myrow As Range
Set Myrange = Selection
For Each Myrow In Myrange.Rows
   If Myrow.Row Mod 2 = 1 Then
      Myrow.Interior.Color = vbCyan
   End If
Next Myrow
End Sub

\'高亮显示所有带评论的单元格
Sub HighlightCellsWithComments()
ActiveSheet.Cells.SpecialCells(xlCellTypeComments).Interior.Color = vbBlue
End Sub

\'高亮显示选定区域内所有的空单元格
Sub HighlightBlankCells()
Dim Dataset as Range
Set Dataset = Selection
Dataset.SpecialCells(xlCellTypeBlanks).Interior.Color = vbRed
End Sub

\'将所有的图表调整为同样大小
Sub Resize_Charts()
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 FileBackUp()
ThisWorkbook.SaveCopyAs Filename:=ThisWorkbook.Path & _
"" & Format(Date, "mm-dd-yy") & " " & _
ThisWorkbook.name
End Sub

\'删除选中单元格区域的空格字符
Sub RemoveSpaces()
Dim myRange As Range
Dim myCell As Range
Select Case MsgBox("You Can\'t Undo This Action. " _
& "Save Workbook First?", _
vbYesNoCancel, "Alert")
Case Is = vbYesThisWorkbook.Save
Case Is = vbCancel
Exit Sub
End Select
Set myRange = Selection
For Each myCell In myRange
If Not IsEmpty(myCell) Then
myCell = Trim(myCell)
End If
Next myCell
End Sub

\'将选定单元格区域内的空单元格以0填充
Sub replaceBlankWithZero()
Dim rng As Range
Selection.Value = Selection.Value
For Each rng In Selection
If rng = "" Or rng = " " Then
rng.Value = "0"
Else
End If
Next rng
End Sub

\'合并多个工作表，这些工作表要有同样的表头，并且没有合并单元格
Option Explicit
Sub hebing()
    \'把各班成绩表中的记录合并到"成绩表"工作表中
    Dim sht As Worksheet
    Set sht = Worksheets("成绩表")\'你要合并在哪张工作表，就把哪张工作表的名字输入进去即可
    sht.Rows("2:65536").Clear      \'删除成绩表中的原有记录
    Dim wt As Worksheet, xrow As Integer, rng As Range
    For Each wt In Worksheets                   \'循环处理工作簿中的每张工作表
        If wt.Name <> "成绩表" Then\'你需要合并数据的那张工作表的名字
            Set rng = sht.Range("A1048576").End(xlUp).Offset(1, 0)
            xrow = wt.Range("A1").CurrentRegion.Rows.Count - 1
            wt.Range("A2").Resize(xrow, 7).Copy rng\'数字7对应你要合并的工作表有多少列就写几，在本例中是7.
        End If
    Next
End Sub

合并多个工作表

\'合并多个Excel文件，这些工作表要有同样的表头，并且没有合并单元格
Option Explicit
Sub HzWb()
    Dim bt As Range, r As Long, c As Long
    r = 1    \'1 是表头的行数
    c = 7    \'7 是表头的列数
    Dim wt As Worksheet
    Set wt = ThisWorkbook.Worksheets(1)    \'将汇总表赋给变量wt
    wt.Rows(r + 1 & ":1048576").ClearContents  \' 清除汇总表中原表数据,只保留表头
    Application.ScreenUpdating = False
    Dim FileName As String, sht As Worksheet, wb As Workbook
    Dim Erow As Long, fn As String, arr As Variant
    FileName = Dir(ThisWorkbook.Path & "\*.xlsx")
    Do While FileName <> ""
        If FileName <> ThisWorkbook.Name Then        \' 判断文件是否是汇总数据的工作簿
            Erow = wt.Range("A1").CurrentRegion.Rows.Count + 1     \' 取得汇总表中第一条空行行号
            fn = ThisWorkbook.Path & "\" & FileName     \'将第1个要汇总的工作簿名称赋给变量fn
            Set wb = GetObject(fn)        \' 将变量fn 代表的工作簿对象赋给变量wb
            Set sht = wb.Worksheets(1)    \' 将要汇总的工作表赋给变量sht
            \' 将工作表中要汇总的记录保存在数组arr里
            arr = sht.Range(sht.Cells(r + 1, "A"), sht.Cells(1048576, "B").End(xlUp).Offset(0, 5))
            \' 将数组arr 中的数据写入工作表
            wt.Cells(Erow, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
            wb.Close False
        End If
        FileName = Dir    \' 用Dir 函数取得其他文件名，并赋给变量
    Loop
    Application.ScreenUpdating = True
End Sub

合并多个文件

---

宏代码系列到这里就结束了，Excel篇就讲这么多了。后面有了新的体会的时候再来分享。普通用户学会这些已经用的很不错了。本系列至此结束。