Sub 合并数据()
'合并指定目录中所有文件中相同格式工作表的数据
'见http://club.excelhome.net/dispbbs.asp?
boardid=1&replyid=900613&id=249319&page=1&skin=0&Star=2帖11楼eq800的代码
    Dim myPath$, myFile$, AK As Workbook, aRow%, tRow%, i As Integer
    Application.ScreenUpdating = False        '冻结屏幕，以防屏幕抖动
    myPath = ThisWorkbook.Path & "\分表\"          '把文件路径定义给变量
    myFile = Dir(myPath & "*.xls")            '依次找寻指定路径中的*.xls文件
    Do While myFile <> ""                     '当指定路径中有文件时进行循环
        If myFile <> ThisWorkbook.Name Then
            Set AK = Workbooks.Open(myPath & myFile)          '打开符合要求
的文件
            For i = 1 To AK.Sheets.Count
                aRow = AK.Sheets(i).Range("a65536").End(xlUp).Row
                tRow = ThisWorkbook.Sheets(1).Range("a65536").End(xlUp).Row
+ 1
                'AK.Sheets(i).Select
                AK.Sheets(i).Range("a3:k" & aRow).Copy ThisWorkbook.Sheets
(1).Range("a" & tRow)  '取得第3行以后的数据
            Next
            Workbooks(myFile).Close False               '关闭源工作簿,并不作
修改
        End If
        myFile = Dir                                   '找寻下一个*.xls文件
    Loop
    Application.ScreenUpdating = True                 '冻结屏幕,此类语句一般
成对使用
    MsgBox "汇总完成，请查看！", 64, "提示"
End Sub

Sub 合并数据()
'合并指定目录中所有文件中相同格式工作表的数据
'见http://club.excelhome.net/dispbbs.asp?
boardid=1&replyid=900613&id=249319&page=1&skin=0&Star=2帖11楼eq800的代码
    Dim myPath$, myFile$, AK As Workbook, aRow%, tRow%, i As Integer
    Application.ScreenUpdating = False        '冻结屏幕，以防屏幕抖动
    myPath = ThisWorkbook.Path & "\分表\"          '把文件路径定义给变量
    myFile = Dir(myPath & "*.xls")            '依次找寻指定路径中的*.xls文件
    Do While myFile <> ""                     '当指定路径中有文件时进行循环
        If myFile <> ThisWorkbook.Name Then
            Set AK = Workbooks.Open(myPath & myFile)          '打开符合要求
的文件
            For i = 1 To AK.Sheets.Count
                aRow = AK.Sheets(i).Range("a65536").End(xlUp).Row
                tRow = ThisWorkbook.Sheets(1).Range("a65536").End(xlUp).Row
+ 1
                'AK.Sheets(i).Select
                AK.Sheets(i).Range("a3:k" & aRow).Copy ThisWorkbook.Sheets
(1).Range("a" & tRow)  '取得第3行以后的数据
            Next
            Workbooks(myFile).Close False               '关闭源工作簿,并不作
修改
        End If
        myFile = Dir                                   '找寻下一个*.xls文件
    Loop
    Application.ScreenUpdating = True                 '冻结屏幕,此类语句一般
成对使用
    MsgBox "汇总完成，请查看！", 64, "提示"
End Sub