vba set语句_【Office手账】Excel：使用VBA合并工作簿/批量另存工作表

最新推荐文章于 2024-06-27 15:30:11 发布

weixin_39649614

最新推荐文章于 2024-06-27 15:30:11 发布

阅读量775

点赞数 1

写在前面：

Office办公套件(Word，Excel，PowerPoint等)是我们最常接触的工作软件。它们的功能非常强大：Word可以制作排版精美的文档，Excel有强大的数据统计与处理功能，PowerPoint则可以很好地方便我们向他人展示我们的观点。只要用好这三个软件，处理日常的工作和生活事务就会变得相当容易。

我的office水平并不算很强，有很多简便的操作和函数对我来说仍是未知领域，VBA也只是入门水平，编译不通过或者运行出bug也是经常的事。为了努力提高自己的知识水平，我会不定期地写一些office操作的小手账，强化自身学习的同时，也和大家一起分享。水平粗浅，如有错漏或可以改进之处，欢迎大家提出

提示：这篇学习手账涉及编程，适合有一定编程基础的同志阅读

案例：合并多个工作簿

我们也许经常能遇到如下图所示的情况。

总是有一些令人生厌的数据源，明明放在一张表格里的事情，它偏要给你来上三五张表，甚至十几二十张表。有些表格还分Sheet来存放数据。

这个案例里尚且只有3个工作簿总共不到10个工作表，在数据量大的情况下可能会有几十张表，手动复制粘贴怕是会粘到头皮发麻。

有时候粘贴完了还不够，还要分部门/分人头将表格拆分，以分别发送给相应人员。如果要拆分很多次的话……

这一期我们使用VBA来将这些表格一键整合到一起，同时一键将一个工作簿中的不同工作表分别另存。

撰写打开工作簿并复制其内容的代码

这个代码的核心思路很简单：打开已有的工作簿文件，复制工作簿的每个工作表，粘贴到当前的工作簿之中。

新建一个工作簿之后，首先想办法打开已有的工作簿。VBA对于打开工作簿文件的理解是：给它一个工作簿地址的字符串，然后解析这个字符串地址来打开工作簿。可以使用Application.GetOpenFilename方法，调用打开文件的窗口，获取要打开的工作簿所在地址。这个方法的一般使用形式如下：

Application.GetOpenFilename([FileFilter/文件类型过滤器], [FilterIndex/过滤器索引], [Title/标题], [ButtonText/按钮文本(仅限MAC系统)], [MultiSelect/是否多选])

我们一般用到的就是FileFilter，Title和MultiSelect三个参数。FileFilter是一个字符串，VBA会自动解析其中的星号、逗号、分号等字符，从而在打开文件的对话框中指定文件类型。

'注意这里的Variant类型：如果要判断是否选择了文件(即是否在弹出的对话框中点了关闭或取消按钮)，就要设置Variant类型。

'定义File作为单个文件的地址，Filename作为文件地址的集合。

Dim File As Variant, Filename As Variant

Filename = Application.GetOpenFilename(FileFilter:="Excel工作簿文件, *.xls;*.xlsx;*.xlsm;*.csv", Title:="请选择您要复制的工作簿", MultiSelect:=True)

实现的效果如下图所示。

选择这三个工作簿之后按“打开”，这三个工作簿的地址就会输入到Filename变量中。如果点击右上角的“×”或右下角的“取消”，则会返回一个False逻辑值到Filename变量中。如果定义Filename的变量类型是字符串型，程序就会报错，而如果定义的变量类型是Variant则程序会继续进行。

为了不因为误点“取消”或“×”导致程序出错，我们加一个小小的错误处理子过程。

'该子过程用于点击“取消”时退出程序

Private Sub EXITPROGRAM()

    MsgBox "您取消了程序。程序结束。", vbOKOnly + vbExclamation, "太阳矩阵核心提示"

    'End关键字可直接终止主程序。

    End

End Sub

(关于MsgBox函数可参阅上期推文)

判断点了“取消”和“×”的方法也很简单。由于点了这两个按钮之后对话框会返回False值，而这是一个逻辑(Boolean)值，而不点这两个按钮意味着选择了文件(不选择文件是不能点击“打开”的)、对话框返回字符串值，因此使用VarType函数判定返回的值类型即可：

'如果If...Then...在一行内编写完成，则不需要End If

If VarType(Filename) = vbBoolean Then EXITPROGRAM

我们需要将代码所在的工作簿和需要复制的工作簿圈定下来，以确保复制的目标不会跑错。

'可以直接将变量定义为对象(Workbook，Worksheet等)

Dim ThisWB As Workbook, CopyWB As Workbook

'给对象类型的变量“赋值”，要使用Set关键字

'ThisWorkbook代表代码所在的工作簿

Set ThisWB = ThisWorkbook

接下来我们从文件名中循环读取每一个工作簿，并复制其中的内容。由于Filename变量中存储了三个文件名，相当于一个数组类型的变量，因此我们可以采取For Each ... Next这样的数组循环。

对于每个文件名，我们都要进行“解析”，来获取正确的对象。我们可以使用GetObject函数来实现。GetObject函数的用法为：

GetObject([路径/PathName], [对象类型/Class])

VBA能自动识别工作簿等内置的类别，因此在本例中我们可以直接省略Class参数。至于路径参数，就是Filename中的每一个路径文本串了。

我们知道，所有的工作簿下面都有若干个工作表。我们可以简单地使用Count方法来获取工作簿下面有多少个工作表，然后使用Copy方法来复制工作表。Copy方法的用法为：

Worksheet.Copy [放在某表之前/Before], [放在某表之后/After]

对一个工作表执行Copy命令后，Excel就会自动生成一张工作表，放在指定的工作表之前/之后(这个工作表可以是任意一个工作簿中的)。如果省略了Before和After参数，那么Excel就会自动建立一个新的空白工作簿并插入这个复制的工作表。

执行完命令之后要关闭工作簿，使用工作簿的Close方法关闭(否则我们想粘贴几个工作簿的内容，执行完成后就会有几个工作簿的窗口)。Close方法的用法为：

Workbook.Close [是否保存/SaveChanges], [保存更改后的文件名/Filename], [发送工作簿/RouteWorkbook]

我们不需要保存工作簿，也不需要发送工作簿，因此将第一个参数设置为False即可。本段代码整合后如下所示：

'File和Filename都是Variant变量，因此其可以作为Filename集合的一个元素参与循环，不需要预先给File定义值。

'类似的还有Workbook和Workbooks、Worksheet和Worksheets等

For Each File In Filename

    Set CopyWB = GetObject(File)

    For i = 1 To CopyWB.Worksheets.Count Step 1

        'Sheets(i)代表标签序号为i的工作表

        '特别注意：请务必思考清楚所需要的工作表顺序

        CopyWB.Sheets(i).Copy After:=ThisWB.Sheets(1)

        '工作表在复制时会复制原有的名称，如果与已有工作表重名则会发生错误导致程序停止。使用On Error Resume Next来跳过错误，此时Excel会自动对重名的工作表重新命名。

        On Error Resume Next

    Next i

    'False针对的是Close方法的第一个参数，因此可以直接不写参数名。

    CopyWB.Close False

Next File

整合后的代码如下所示。

'该子过程用于点击“取消”时退出程序

Private Sub EXITPROGRAM()

    MsgBox "您取消了程序。程序结束。", vbOKOnly + vbExclamation, "太阳探机的提示"

    End

End Sub

'主程序

Sub 复制指定工作簿的所有工作表()

    'Chr(13)代表换行符

    MsgBox "本程序将打开若干工作簿，" & Chr(13) & "复制其中的所有工作表并插入本工作簿。", vbOKOnly + vbInformation, "太阳探机的提示"

    MsgBox "请选择您要复制的工作簿。", vbOKOnly + vbInformation, "太阳探机的提示"

    Dim File As Variant, Filename As Variant, ThisWB As Workbook, CopyWB As Workbook, i&

    Filename = Application.GetOpenFilename(FileFilter:="Excel工作簿文件, *.xls;*.xlsx;*.xlsm;*.csv", Title:="请选择您要复制的工作簿", MultiSelect:=True)

    If VarType(Filename) = vbBoolean Then EXITPROGRAM

    '设置DisplayAlerts为False来跳过工作表重名的确认环节

    With Application

        .ScreenUpdating = False

        .DisplayAlerts = False

    End With

    Set ThisWB = ThisWorkbook

    For Each File In Filename

        Set CopyWB = GetObject(File)

        For i = 1 To CopyWB.Worksheets.Count Step 1

            CopyWB.Sheets(i).Copy After:=ThisWB.Sheets(1)

            On Error Resume Next

        Next i

        CopyWB.Close False

    Next File

    '不重新开启ScreenUpdating的话，下面的MsgBox语句将无法出现执行效果

    Application.ScreenUpdating = True

    MsgBox "已成功完成工作表的复制。", vbOKOnly + vbInformation, "太阳探机的提示"

End Sub

实际执行一下。等待若干秒以后(时间主要浪费在重复的打开、关闭工作簿的操作中)，即可发现所有工作表都已经转入到了我们新建的工作簿中。

接下来执行第二步：将其它工作表中的数据转移到活动的工作表中。

复制其它工作表的内容到一张工作表中

这一步比刚才更加简单。在上面的操作中，我们把所有的工作表都放在了这个工作簿自带的工作表(Sheet1)之后，因此只需要跳转回第一个工作表，再执行代码将其它工作表的内容复制过来即可。只需要很简单的代码即可完成：

Sub 复制所有工作表到特定表()

    Application.ScreenUpdating = False

    Dim i&

    For i = 2 To ThisWorkbook.Worksheets.Count Step 1

        '通过EntireRow来选中整行。这样做是为了避免复制时，由于各工作表的列数不统一导致出现错位的情况。

        '例如，表1有5列，但表2只有4列。如果不选中整行将表2复制到表1的话，那么插入复制的单元格时，如果指定活动单元格下移，就只有前4列会下移，而第5列会不动，从而产生错位。

        Sheets(i).UsedRange.EntireRow.Copy

        ThisWorkbook.ActiveSheet.Rows(1).Insert

    Next i

    Application.ScreenUpdating = True

    MsgBox "已从其它工作表中复制所有内容到活动工作表。", vbOKOnly + vbInformation, "太阳探机的提示"

End Sub

执行之后的效果如图所示：

再写一个更简单的代码，删除多余的表头：

Sub 删除多余表头()

    Dim i&

    '这里的循环是从最后一行往上走的，各位可以想一想为什么要这样走

    For i = ActiveSheet.UsedRange.Rows.Count To 2 Step -1

        '整行删除之后，下方的单元格会上移

        If Cells(i, 1).Value = "工号" Then Rows(i).EntireRow.Delete

    Next i

    MsgBox "已删除多余表头。", vbOKOnly + vbInformation, "太阳探机的提示"

End Sub

执行的效果如下：

再写一个最简单的代码，删除其它的无用表格：

Sub 删除无用表格()

    Dim i&

    '关闭DisplayAlerts来避免重复确认。注意：工作表删除后不可撤销，请谨慎处理。

    Application.DisplayAlerts = False

    If ThisWorkbook.Worksheets.Count > 1 Then

        '这里的循环也是从最后一个往前走的，各位可以想一想为什么要这样走

        For i = ThisWorkbook.Worksheets.Count To 2 Step -1

            ThisWorkbook.Sheets(i).Delete

        Next i

        MsgBox "已删除多余的表格。", vbOKOnly + vbInformation, "太阳探机的提示"

    Else

        MsgBox "没有多余的表格。", vbOKOnly + vbExclamation, "太阳探机的提示"

    End If

End Sub

执行的效果：

如果在只有一个工作表的情况下运行，则会弹出提示信息：

是不是很完美？别急，更完美的还在下面~

分别保存每个工作表的内容

假设在上面这张表中，我们需要将表按照部门拆分，分别保存。拆分的过程这里略过(可以用VBA实现，欢迎大家思考)，表如图所示：

其思想非常简单。我们之前有提到，Worksheet的Copy方法如果省略了Before和After参数，那么Excel就会自动建立一个新的空白工作簿并插入这个复制的工作表。我们可以灵活运用这一点，并使用Application.Dialogs属性的Show方法来弹出“另存为”对话框，供选择保存路径。代码如下：

'该子过程用于点击“取消”时退出程序

Private Sub EXITPROGRAM()

    MsgBox "您取消了程序。程序结束。", vbOKOnly + vbExclamation, "太阳探机的提示"

    End

End Sub

Sub 将工作表分别另存()

    Dim i&, Response As Variant

    For i = 1 To ThisWorkbook.Worksheets.Count Step 1

        ThisWorkbook.Sheets(i).Copy

        'Show方法会弹出“另存为”对话框。弹出对话框时可以查看工作簿的内容以及下方的标签，以防忘记当前保存的工作簿。

        Response = Application.Dialogs(xlDialogSaveAs).Show

        If Response = False Then

            ActiveWorkbook.Close False

            EXITPROGRAM

        End If

    ActiveWorkbook.Close False

    Next i

    MsgBox "已将所有" & ThisWorkbook.Worksheets.Count & "个工作表另存。", vbOKOnly + vbInformation, "太阳探机的提示"

End Sub

实现的效果如图所示：

本章使用到的方法、函数汇总

Application.GetOpenFilename方法：https://docs.microsoft.com/zh-cn/office/vba/api/excel.application.getopenfilename

GetObject函数：https://docs.microsoft.com/zh-cn/office/vba/language/reference/user-interface-help/getobject-function

Worksheet.Copy方法：https://docs.microsoft.com/zh-cn/office/vba/api/excel.worksheet.copy

Workbook.Close方法：https://docs.microsoft.com/zh-cn/office/vba/api/excel.workbook.close

VarType函数：https://docs.microsoft.com/zh-cn/office/vba/language/reference/user-interface-help/vartype-function

Range.Copy方法：https://docs.microsoft.com/zh-cn/office/vba/api/excel.range.copy

Range.Insert(Rows、Columns其实都属于Range对象)方法：https://docs.microsoft.com/zh-cn/office/vba/api/excel.range.insert

Application.Dialogs属性：https://docs.microsoft.com/zh-cn/office/vba/api/excel.application.dialogs

另可参考：

Range.PasteSpecial方法(可执行行列转置、保留源列宽等特殊粘贴操作)：https://docs.microsoft.com/zh-cn/office/vba/api/excel.range.pastespecial

▼

学好VBA

走遍天下都不怕

▶THE END◀

太阳矩阵核心

一颗人工恒星

真的很厉害哦

不扫一扫关注一下吗

根据微信政策，从今年3月起，所有新开的微信公众号都将暂时不开放留言功能，具体什么时候再开放是个未知数。想要留言的小伙伴们，欢迎在后台留言嘿~

weixin_39649614

关注

1
点赞
踩
2

收藏

觉得还不错? 一键收藏
0
评论
复制链接

分享到 QQ

分享到新浪微博

扫一扫