如何将同一目录下的多个excel工作薄合并成一个新的汇总文件

394167692

具体要求：1 同一个文件夹（目录）内包含多个excel工作薄文件，注意后缀可能是xls，也有可能是xlsx。（例如有的老师保存为2003格式的，有的保存为2007格式的工作薄）
2 只汇总每个excel工作薄里面的sheet1，其他的例如sheet2，sheet3 类似的，都不用统计。
3 由于sheet1的表头都是一样的，假设都有三行，在汇总的时候，只保留一个表头，后面的表头不要了（避免重复）4 在汇总的时候要求按照顺序来，不能是先统计xls类型，后统计xlsx类型。（例如统计5个班的学生成绩，要求从第1个班汇总到第5个班，假设3班的老师交来的是xlsx，不能把3班放到最后。）
5 注意是汇总到一个新的工作薄的sheet1里面 ，不是每个工作薄对应一张sheet

394167692

网上有一个类似的，但是有几处还不满足我的要求
第一 这个只能合并xls 无法同时混合合并xls和xlsx
第二 这个合并的是所有sheet，而我只需要合并sheet1就够了。
代码如下：
Sub 合并当前目录下所有工作簿的全部工作表()
    Dim MyPath, MyName, AWbName
    Dim Wb As Workbook, WbN As String
    Dim G As Long, k As Integer
    Dim Num As Long
    Dim BOX As String
    Application.ScreenUpdating = False
    MyPath = ActiveWorkbook.Path
    MyName = Dir(MyPath & "\" & "*.xls")
    AWbName = ActiveWorkbook.Name
    Num = 0
    Do While MyName <> ""
        If MyName <> AWbName Then
            Set Wb = Workbooks.Open(MyPath & "\" & MyName)
            Num = Num + 1
            With Workbooks(1).ActiveSheet
                .Cells(.Range("B" & Rows.Count).End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)
                For G = 1 To Sheets.Count
                    k = k + 1
                    If k = 1 Then '如果第一次复制，就进行复制标题
                        Wb.Sheets(G).UsedRange.Copy .Cells(.Range("B" & Rows.Count).End(xlUp).Row + 1, 1)
                    Else '否则就下移四行（假设标题四行） .Offset(4) 下移二行改这个4为标题实际行数
                        Wb.Sheets(G).UsedRange.Offset(4).Copy .Cells(.Range("B" & Rows.Count).End(xlUp).Row + 1, 1)
                    End If
                Next
                WbN = WbN & Chr(13) & Wb.Name
                Wb.Close False
            End With
        End If
        MyName = Dir
    Loop
    Range("B1").Select
    Application.ScreenUpdating = True
    MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
End Sub

LMY123

多薄多表合并成一薄一表

lrh788

394167692 发表于 2015-9-2 17:59
网上有一个类似的，但是有几处还不满足我的要求
第一 这个只能合并xls 无法同时混合合并xls和xlsx
第二  ...

能否请大大们优化下代码 ，加快运行速度，此代码如遇到100多个表，几十万数据就特慢！！！！