|
本次我们要写一个一键合并多个sheet的VBA小工具。展示的时候都是图片展示，文章最后面有源代码可以复制。大家可以复制尝试。 这其中涉及到的Range和相对路径的知识点，大家可以前往其他文章查看。 （1）Range的用法 第一天 （2）VBA中的相对路径第二天 本章我们会整理一些比较细碎的知识点。 并且完成我们的第一个小功能！合并多个sheet！ 使用Now()方法为合并后的EXCEL文件命名因为考虑到源数据变化，我们需要不断的点击合并。因此这里需要有一个动态的命名方法。如果将命名写成固定的名称，在重复导出的时候会出错。 首先Now()函数返回当前的日期+星期+时间，返回的是Date类型的，所以我们需要使用CDate()函数将Now()的返回值转化为字符串。 这边我们发现输出的字符串有空格，也有冒号【：】字符，正常的文件名，不允许这样的字符出现。因此我们需要对字符串进行替换处理。 使用Replace()方法替换命名中不合法的字符Replace()方法接受3个参数，非常简单 Replace(需要操作的字符串，查找的字符，替换的字符) 为了美观，我们把斜杠号【/】也一并去除。 这样命名这部分就完成了。 使用Workbooks.Add方法，新建EXCEL文件，存放汇总后的数据这个方法十分简单，只需2行代码，就可以新建一个EXCEL文件。 这里实测运行无误。 存放数据的容器都有了，但是我们却没有保存，这里就需要使用到上面和以前的知识点了。 我们将该新建的EXCEL文件存放在源数据表的同级目录。 这边为了后期修改，我们将该功能封装成一个函数，该函数返回我们新建的EXCEL对象。供合并使用。 这边我们已经解决了一个较为关键的知识点。 现在我们就得开始合并每个sheet的内容了。VBA合并sheet本质上就是模拟人工，我们人为合并的时候，（假设3个sheet）操作顺序是这样的： ①打开第1个sheet，复制，粘贴到指定的EXCEL中。（第1次复制粘贴带着表头） ②打开第2个sheet，复制，粘贴到指定的EXCEL中。（第2次复制粘贴不带着表头） ③打开第3个sheet，复制，粘贴到指定的EXCEL中。（第3次复制粘贴不带着表头） 因此这边就需要循环一个EXCEL中的所有Sheet。 所以我们就需要下面的知识点！ 使用For...Each循环每个Sheet大家可以看一下图，在使用For Each的时候，不要忘了加上Next。 既然我们可以循环到每个sheet了，那我们就可以操作每个sheet中的数据，然后复制到存放的表了。但是由于循环的操作都是一样的。所以第一次复制表头而二三次不复制表头循环里写是不太美观的。因此，我们把复制表头单独列出来写。 并且我们将合并后要存放的数据存放EXCEL，作为我们的参数，这样后期的修改会比较方便。 这样就完成了！ 可以参考下动图： 以下是源代码，大家可以尝试一下。有任何问题欢迎大家留言~ Sub Run() Dim tar_wb As Workbook Set tar_wb = CreateWorkbook Call MergeContent(tar_wb)End Sub'函数名: CreateWorkbook'接受参数：无'返回值：Workbook（返回创建的Workbook）'说明：创建一个Excel文件，存放合并的数据Private Function CreateWorkbook() As Workbook Dim fileName As String Dim filePath As String Dim nowDate As String nowDate = CDate(Now()) nowDate = Replace(nowDate, ':', '') nowDate = Replace(nowDate, '/', '') nowDate = Replace(nowDate, ' ', '_') filePath = ThisWorkbook.path & '\' fileName = filePath & nowDate & '_汇总表.xlsx' Dim newBook As Workbook Set newBook = Workbooks.Add With newBook .SaveAs fileName End With Set CreateWorkbook = newBookEnd Function'函数名: MergeContent'接受参数：targetWorkbook（合并后的数据存放的Workbook对象）'返回值：无'说明：将数据依次粘贴到目标Workbook对象、即EXCEL中。Private Function MergeContent(targetWorkbook As Workbook) '复制粘贴表头 Sheet1.Range(Sheet1.Cells(1, 1), Sheet1.Cells(1, 1).End(xlToRight)).Copy _ targetWorkbook.Sheets('Sheet1').Range('A65536').End(xlUp) '循环每个Sheet，然后把数据复制到存放EXCEL For Each sht In ThisWorkbook.Worksheets sht.Range('A1').CurrentRegion.Offset(1, 0).Copy _ targetWorkbook.Sheets('Sheet1').Range('A65536').End(xlUp).Offset(1, 0) Next '完成后，将存放EXCEL关闭，并且保存 targetWorkbook.Close TrueEnd Function |
|
|
