d.VBA实现Excel多个工作簿合并成一个工作表

    越发深挖VBA,越发感觉到自己的编程能力有待提高。主要表现在:1、遇到问题不知怎么下手分析(思路);2、分析之后不知怎么入手去做(基础);3、程序调试(能力)
    针对以上问题,我咨询了资深专家。目前解决方法是:多看、多练,针对问题可先去找类似的程序代码,后不断修改完善(并不要求完全从0开始)。

多个工作簿合并成一个工作表

先贴代码:

Sub 合并工作簿至一个工作表()
Dim MyPath$, MyName$, sh As Worksheet, sht As Worksheet, m&, IsSheetEmpty As Boolean
'设置文本型MyPath、MyName,最终存放工作簿sh,需要读取的工作簿sht,长整型m,布尔型IsSheetEmpty'
Set sh = ActiveSheet
'sh为当前活动表格'
MyPath = ThisWorkbook.Path & "/"   '此处应输入左斜杠'
'获得当前文件文件夹路径'
MyName = Dir(MyPath & "*.xls")
'指定当前文件夹内所有以 ".xls"结尾的文件'
Application.ScreenUpdating = False
'Application.ScreenUpdating 在Excel的工作表里面数据发生变化后False禁止实时刷新,True[默认值]为表示实时更新数据'
Cells.ClearContents
'清除当前表格的单元格内容'
Do While MyName <> ""        '如果不存在下一个文件,则跳出循环'
    If MyName <> ThisWorkbook.Name Then   '不执行当前文件'
        With GetObject(MyPath & MyName)      '获得文件对象'
        For Each sht In .Sheets          '依次执行文件下的Sheets'
          If IsSheetEmpty = IsEmpty(sht.UsedRange) Then      'UsedRange是工作表属性'
             m = m + 1                         
             If m = 1 Then                    
                sht.[A1].CurrentRegion.Copy sh.[A1]    
             Else
                sht.[A1].CurrentRegion.Offset(0).Copy sh.[A65536].End(xlUp).Offset(1)
             End If
          End If
        Next
        .Close False
        End With
    End If
    MyName = Dir
  Loop
Application.ScreenUpdating = True
MsgBox "所有表格已完成合并"
End Sub

注意需复制在当前文件上,文件保存为.xlsm

代码讲解

整体思路:
1、获得当前文件路径MyPath,获取当前文件夹下所有文件Dir;
2、采用两层循环,逐个读取当前工作簿,再向下读取工作簿中的工作表;
3、实现工作表批量读取并复制到当前文件中。

两层循环、一个语句块:
第一层循环 主要循环查找工作簿,使用Dir实现下一文件读取

Do While MyName<>""    '循环的终止条件为文件名为空,不为空则执行'  
    循环体()                '执行下层循环'  
    MyName=Dir             '实现读取下一工作簿,相当于n++'
Loop

语句块 获得工作表对象

With GetObject(MyPath & MyName)     '返回文件中的 ActiveX 对象的引用,当执行上述代码时,就会启动与指定的 pathname 相关联的应用程序,同时激活指定文件中的对象'
    .Sheets                   '获得当前对象所对应的Sheets'
    .Close False           'Workbooks("01.xls").Close False 退出当前对象不报存'
End With

第二层循环 遍历每个工作表

For  Each sht In .Sheets       '遍历每个Sheets对象'
    循环体(执行关键代码)         '执行循环复制'
    Next           '执行下一个Sheets,相当于n++

关键代码:

  • sht.[a1].CurrentRegion.Copy sh.[a1]
  • sht.[a1].CurrentRegion.Offset(0).Copy sh.[a65536].End(xlUp).Offset(1)

CurrentRegion属性
Range的CurrentRegion属性返回的是一个单元格对象;
Offset属性
Range的Offset属性,它代表位于指定单元格区域的一定的偏移量位置上的区域。

VBA对象类型
$ 文本型; % int 整型; & 长整型 long; ! Single 单精度; #double 双精度 ;

最后编辑于
©著作权归作者所有,转载或内容合作请联系作者
平台声明:文章内容(如有图片或视频亦包括在内)由作者上传并发布,文章内容仅代表作者本人观点,简书系信息发布平台,仅提供信息存储服务。