Excel精英培训网

 找回密码
 注册

QQ登录

只需一步,快速开始

工作中常用的Excel函数公式,全印在一张超大鼠标垫上
查看: 7824|回复: 24

[已解决] 用vba实现多工作簿多表合并到一簿多表

[复制链接]
发表于 2011-11-4 20:46 | 显示全部楼层 |阅读模式
分别合并文件夹.rar (16.48 KB, 下载次数: 88)
发表于 2011-11-5 09:33 | 显示全部楼层
多文件分别合并.rar (24.18 KB, 下载次数: 560)

评分

参与人数 2 +4 收起 理由
shenlong2006 + 3
tlg5780282 + 1 很给力!

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2011-11-5 23:03 | 显示全部楼层
太感谢zjdh  了!能否实现自动判断工作表的数量?有时候汇总的工作簿和被汇总的工作簿都可能包含多个工作表,数量不确定的,再次感谢!
回复

使用道具 举报

 楼主| 发表于 2011-11-5 23:14 | 显示全部楼层
Sub TEST()
    Application.ScreenUpdating = False
    For Each ST In Sheets
        ST.UsedRange.Offset(1, 0).ClearContents
    Next
    MyPath = ThisWorkbook.Path
    MYFILE = Dir(MyPath & "\*.xls")
    Do Until MYFILE = ""
        If MYFILE <> ThisWorkbook.Name Then
            Set FS = Workbooks.Open(MyPath & "\" & MYFILE)
            For I = 1 To 4
                With FS.Sheets(I)
                    .Range("A2:D" & Range("A65536").End(3).Row).Copy ThisWorkbook.Sheets(I).Range("A65536").End(3)(2)
                End With
            Next
            FS.Close
        End If
        MYFILE = Dir
    Loop
    Application.ScreenUpdating = True
End Sub
高手!我明白了,谢谢!刚才没注意看清楚就提问了,看来还是要自己动脑筋哈,可以加入统计工作表数量的语句或者自己改数字。
回复

使用道具 举报

发表于 2011-11-5 23:20 | 显示全部楼层
这个要好好学习学习。
回复

使用道具 举报

 楼主| 发表于 2011-11-5 23:28 | 显示全部楼层
Sub TEST()
    Application.ScreenUpdating = False
    For Each ST In Sheets
        ST.UsedRange.Offset(1, 0).ClearContents
    Next
    MyPath = ThisWorkbook.Path
    MYFILE = Dir(MyPath & "\*.xls")
    j = ThisWorkbook.Sheets.Count
    Do Until MYFILE = ""
        If MYFILE <> ThisWorkbook.Name Then
            Set FS = Workbooks.Open(MyPath & "\" & MYFILE)
            For I = 1 To j
                With FS.Sheets(I)
                    .Range("A2:D" & Range("A65536").End(3).Row).Copy ThisWorkbook.Sheets(I).Range("A65536").End(3)(2)
                End With
            Next
            FS.Close
        End If
        MYFILE = Dir
    Loop
    Application.ScreenUpdating = True
End Sub
改进了一下
回复

使用道具 举报

 楼主| 发表于 2011-11-5 23:36 | 显示全部楼层
还需要改进不限每个表中的列数。
回复

使用道具 举报

 楼主| 发表于 2011-11-5 23:54 | 显示全部楼层
恳请zjdh 大师详解一下这句的具体用法和意义 :
.Range("A2:d" & Range("A65536").End(3).Row).Copy ThisWorkbook.Sheets(I).Range("A65536").End(3)(2)
回复

使用道具 举报

发表于 2011-11-7 10:42 | 显示全部楼层
tlg5780282 发表于 2011-11-5 23:36
还需要改进不限每个表中的列数。

只要把:
.Range("A2:d" & Range("A65536").End(3).Row).Copy ThisWorkbook.Sheets(I).Range("A65536").End(3)(2)
改为
.Range("A2:W" & Range("A65536").End(3).Row).Copy ThisWorkbook.Sheets(I).Range("A65536").End(3)(2)
W还不能包容最大列号可以再加大!
回复

使用道具 举报

发表于 2011-11-7 10:45 | 显示全部楼层
本帖最后由 zjdh 于 2011-11-7 10:46 编辑
tlg5780282 发表于 2011-11-5 23:54
恳请zjdh 大师详解一下这句的具体用法和意义 :
.Range("A2:d" & Range("A65536").E ...


.Range("A2:D" & Range("A65536").End(3).Row).Copy    '复制源
ThisWorkbook.Sheets(I).Range("A65536").End(3)(2)     ‘粘帖到本工作簿表I中,A列最后一个非空单元的下一个单元(作为左上角单元)
回复

使用道具 举报

*滑块验证:
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2020-8-4 18:42 , Processed in 0.078001 second(s), 4 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 2001-2017 Comsenz Inc.

快速回复 返回顶部 返回列表