请老师编写程序，看看下面要求能不能实现，先谢谢老师了。

zhjg5961

请老师编写程序，看看下面要求能不能实现，先谢谢老师了。

假设有三个工作簿，我想把每个工作簿中的所有内容都批量复制到另一个工作簿中，不知道能不能实现？
注明：（1）“0跨表暴力复制汇总表”工作簿是我要的最后结果；（2）“1铆工车间”、“2办公室”和“3机修车间”三个工作簿是原始数据。

绿谷龙芽

真的有点暴力，我还以为可以温柔点。
不明白为啥不把数据接在一起，又为什么不把最后面的红字的表单独分开，难道这才是需要暴力的目的。
几个不同属性的表放在一起意义何在。

zhjg5961

绿谷龙芽 发表于 2019-10-2 18:02
真的有点暴力，我还以为可以温柔点。
不明白为啥不把数据接在一起，又为什么不把最后面的红字的表单独分开 ...

基层单位发给我的表什么格式的都有，所以最好什么情况都能复制合并。辛苦老师了！

xuemei0216

Sub a()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'当前工作表
Dim sht1 As Worksheet
Set sht1 = ActiveSheet
sht1.UsedRange.Delete            '清除内容,当前工作表
'选择多个文件
Dim arr
arr = Application.GetOpenFilename(FileFilter:="excel文件,*.xls*", MultiSelect:=True)
If Not IsArray(arr) Then Exit Sub
'遍历文件
Dim wb As Workbook, sht As Worksheet
Dim i%, n%, r&
For i = LBound(arr) To UBound(arr)
    Set wb = Workbooks.Open(arr(i))
    For Each sht In wb.Worksheets
        If Application.CountA(sht.Cells) <> 0 Then
            r = sht1.Range("a" & Rows.Count).End(xlUp).Row
            n = IIf(r = 1, 0, 5)
            sht.UsedRange.Copy sht1.Cells(r, 1).Offset(n)
        End If
    Next
    wb.Close
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "合并完成"
End Sub

zhjg5961

xuemei0216 发表于 2019-10-2 19:51
Sub a()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

老师你好：我的电脑这几天坏了，今天刚修好。回复老师晚了，对不起。

zhjg5961

xuemei0216 发表于 2019-10-2 19:51
Sub a()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

老师编写的程序我测试了，要选文件夹和文件。能不能做成自动生成结果的。