水真香 / vba应用 / 对目录下所有的格式相同的EXCEL2003文件进...

分享

   

对目录下所有的格式相同的EXCEL2003文件进行分表合并

2014-10-20  水真香
对目录下所有的格式相同的EXCEL2003文件进行分表合并
Sub 同目录分表合并()
    '对目录下所有的格式相同的EXCEL2003文件进行分表合并
    '注意每个工作表第一行有且为标题行,只复制第2行开始的数据
    '原创精英网FookYou,二○○九年十一月一日zjxia889修改为通用宏
    Dim Arr, MyPath$, MyName$, R&, Col%, aR_n&,shname
    Dim Wb As Workbook '定义源文件,同目录下其它文件
    Dim Ws As Worksheet '定义目标文件,当前文件
    Dim F As Object
     shname=activesheet.name   '定义合并的工作表名
    Application.ScreenUpdating = False
    MyPath = ActiveWorkbook.Path & "\"
    MyName = Dir(MyPath & "*.xls")
    For Each Ws In ActiveWorkbook.Sheets
        '清除原有记录
        Set F = Cells.Find("*", , , , , xlPrevious)
        If Not F Is Nothing Then
            Ws.Rows("2:" & F.Row + 1).Delete '多加一防止只有一行标题行时删除标题
        End If
    Next Ws
    '逐个打开文件相同表名合并
    Do While MyName <> ""
        If MyName <> ActiveWorkbook.name Then '本文件不动作
            Set Wb = GetObject(MyPath & MyName)
            For Each Ws In Wb.Sheets
                With Ws
                     if ws.name=shname then
                    Set F = .Cells.Find("*", , , , , xlPrevious) '求源文件最大行
                    If Not F Is Nothing Then
                        R = F.Row
                        If R > 1 Then '如果只有一行或空表不合并
                            Col = F.Column
                            Arr = .Range(.Cells(2, 1), .Cells(R, Col))
                            Set F = Sheets(Ws.name).Cells.Find("*", , , , , xlPrevious) '求目标文件最大行
                            If F Is Nothing Then
                                aR_n = 2
                                Else
                                aR_n = F.Row + 1
                            End If
                            Sheets(Ws.name).Cells(aR_n, 1).Resize(UBound(Arr), Col) = Arr
                            Sheets(Ws.name).Cells(aR_n, Col + 1).Resize(UBound(Arr)) = MyName '填充文件名
                        End If
                    End If
                   endif
                End With
            Next Ws
            Wb.Close False
            Set Wb = Nothing
            Set Ws = Nothing
        End If
        MyName = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

    本站是提供个人知识管理的网络存储空间,所有内容均由用户发布,不代表本站观点。请注意甄别内容中的联系方式、诱导购买等信息,谨防诈骗。如发现有害或侵权内容,请点击一键举报。

    0条评论

    发表

    请遵守用户 评论公约

    类似文章 更多
    喜欢该文的人也喜欢 更多

    ×
    ×

    ¥.00

    微信或支付宝扫码支付:

    开通即同意《个图VIP服务协议》

    全部>>