[原创]合并各子公司财务报表 VBA 初稿

作者:zilong 日期:2008-12-16

字体大小: 小中大

十几家子公司EXCEL报表需要合并，手工整理，直接挂了~~~
技术支持财务部门，所以书写VBA . 分享如下，呵呵。

'厦门国贸合并各子公司财务报表
'add by IT部杨闽 on 2008.12.15
'mail:dbmaster@163.com
'qq:153560261

Private Sub bt_clearAll_Click()
'清空合并的工作表中的数据

If MsgBox("确认需要清空所有合并的数据？", vbYesNo, "温馨提示") <> vbYes Then Exit Sub

Dim xlSht As Worksheet
   For Each xlSht In Worksheets
    If xlSht.Name <> "资产负债表" And xlSht.Name <> "利润表" Then
     'xlSht.Cells.ClearContents
     xlSht.Cells.Clear
    ElseIf xlSht.Name = "资产负债表" Then
       xlSht.Range("B6:C17").ClearContents
       xlSht.Range("G6:H18").ClearContents
       xlSht.Range("B20:C37").ClearContents
       xlSht.Range("G20:H27").ClearContents
       xlSht.Range("G30:H36").ClearContents
       xlSht.Range("G38:H38").ClearContents
    ElseIf xlSht.Name = "利润表" Then
       xlSht.Range("C6:D14").ClearContents
       xlSht.Range("C16:D18").ClearContents
       xlSht.Range("C20:D20").ClearContents
       xlSht.Range("C22:D23").ClearContents
       xlSht.Range("C25:D26").ClearContents
    End If

   Next

     MsgBox "已先清空所有工作表数据!", 64 + 0, "温馨提示"

End Sub

Private Sub comb_allExcel_Click()
'按钮单击，调用合并EXCEL功能
  Call UnionWorksheets

End Sub

Sub UnionWorksheets()
'厦门国贸IT部合并财务报表过程
'add by yangmin on 2008.12.15
'mail:dbmaster@163.com
'qq:153560261

    Dim i  As Long            ' 循环变量记录每个excel工作簿下，工作表的数量
    i = 0

    Dim j  As Long            ' 循环变量  记录要合并的excel文件数
    j = 0
    Dim insert_row As Long    ' 合并文件中的粘贴位置

    Dim a As Integer          '资产表，利润表具体那些行需要更新数据

    Dim zcount As Integer    '总共要合并的EXCEL文件数
    zcount = 0

    Dim zfinished As Integer   '显示百分比进度

    Application.ScreenUpdating = False





    Dim lj As String
    Dim dirname As String
    Dim nm As String

    lj = ActiveWorkbook.Path  '当前文件路径
    nm = ActiveWorkbook.Name  '当前文件名称
    dirname = Dir(lj & "\*.xls")



'在当前目录下查找有多少个excel工作簿
With Application.FileSearch
    .LookIn = lj
    .Filename = "*.xls"

    .Execute
    If .FoundFiles.Count = 0 or .FoundFiles.Count = 1 Then
        zcount = 1 '未有其他可以合并的表，只有本张EXCEL表
        MsgBox "还没有可以合并的工作簿，请检查。"
        Exit Sub
    Else
        zcount = .FoundFiles.Count - 1
        'MsgBox "找到了" & zcount & "个需要合并的工作簿"
        If MsgBox("确认需要合并当前目录下" & zcount & "个工作簿？", vbYesNo, "温馨提示") <> vbYes Then Exit Sub
    End If

End With


   ' Cells.Clear

    Do While dirname <> ""     '开始遍历当前路径下的所有excel文件


        If dirname <> nm Then  '非本张汇总工作簿
        j = j + 1

        zfinished = j / 3 * 100 '进度百分比
        Application.StatusBar = "当前合并进度 " & zfinished & "%" '显示进度条


            Workbooks.Open Filename:=lj & "\" & dirname

            Workbooks(nm).Activate

            '复制新打开工作簿的工作表的已用区域到当前工作表  '

For i = 1 To Workbooks(dirname).Sheets.Count   '对当前工作簿的各个工作表进行遍历

  With Workbooks(dirname).Sheets(i)

    If j = 1 And Workbooks(dirname).Sheets(i).Name <> "资产负债表" And Workbooks(dirname).Sheets(i).Name <> "利润表" Then     '是第一张表,要表头


     '添加明细表的数据来源 add by ym on 2008.12.16
     Dim m, n As Integer
     m = Workbooks(dirname).Sheets(i).Range("dz1").End(xlToLeft).Column
     n = Workbooks(dirname).Sheets(i).Range("A65536").End(xlUp).Row
     ' MsgBox "这张表共有" & n & "行，" & m & "列。"
     m = m + 1
     Sheets(i).Cells(1, m) = "数据来源"

     Sheets(i).Cells(1, m).Interior.ColorIndex = 37 '背景设置为淡兰色

     If n >= 2 Then
      For a = 2 To n
       Sheets(i).Cells(a, m) = Left(dirname, Len(dirname) - 4) '取文件名
      Next
     End If


     If Workbooks(dirname).Sheets(i).Name = Sheets(i).Name Then
       Workbooks(dirname).Sheets(i).UsedRange.Copy _
        Sheets(i).Range("a65536").End(xlUp).Offset(0, 0) '将打开的需要合并的子EXCEL报表的某sheet，合并到当前sheet的从(0,0)开始的位置
     Else
      MsgBox "工作簿'" & dirname & "'下的工作表'" & Workbooks(dirname).Sheets(i).Name & "'顺序与当前汇总表不同，请检查"
     End If





    ElseIf Workbooks(dirname).Sheets(i).Name <> "资产负债表" And Workbooks(dirname).Sheets(i).Name <> "利润表" Then


     '添加明细表的数据来源 add by ym on 2008.12.16
     'Dim m, n As Integer
     Dim b As Integer

     b = Sheets(i).Range("A65536").End(xlUp).Row '汇总表已经有的行数
     b = b + 1 '当前新加行
     'MsgBox "当前新加行;" & b & "行"

     m = Workbooks(dirname).Sheets(i).Range("dz1").End(xlToLeft).Column
     n = Workbooks(dirname).Sheets(i).Range("A65536").End(xlUp).Row
    If n >= 2 Then

     ' MsgBox "这张表共有" & n & "行，" & m & "列。"
     m = m + 1
     'Sheets(i).Cells(1, m) = "数据来源"
     n = n + b - 1 - 1

      For a = b To n
       Sheets(i).Cells(a, m) = Left(dirname, Len(dirname) - 4)  '取文件名
      Next
     End If


     If Workbooks(dirname).Sheets(i).Name = Sheets(i).Name Then
       .Range(.Cells(2, 1), .Cells.SpecialCells(xlCellTypeLastCell)).Copy _
       Sheets(i).Range("a65536").End(xlUp).Offset(1, 0) '注意这个要从 (1,0)开始追加数据！否则最后会发现会覆盖上次取数的一行数据！！
     Else
      MsgBox "工作簿'" & dirname & "'下的工作表'" & Workbooks(dirname).Sheets(i).Name & "'顺序与当前汇总表不同，请检查"
     End If


    ElseIf Workbooks(dirname).Sheets(i).Name = "资产负债表" Then  '资产负债表的修正

    'Dim a As Integer

    For a = 6 To 37
     If a <> 19 Then
       Sheets(i).Range("b" & a) = Sheets(i).Range("b" & a) + Workbooks(dirname).Sheets(i).Range("b" & a) '  期末余额
       Sheets(i).Range("c" & a) = Sheets(i).Range("c" & a) + Workbooks(dirname).Sheets(i).Range("c" & a) '  年初余额
      End If
    Next

    For a = 6 To 38
      If a <> 19 And a <> 28 And a <> 29 And a <> 37 Then
       Sheets(i).Range("g" & a) = Sheets(i).Range("g" & a) + Workbooks(dirname).Sheets(i).Range("g" & a) '  期末余额
       Sheets(i).Range("h" & a) = Sheets(i).Range("h" & a) + Workbooks(dirname).Sheets(i).Range("h" & a) '  年初余额
      End If
    Next


    ElseIf Workbooks(dirname).Sheets(i).Name = "利润表" Then '利润表的修正

    For a = 6 To 26
     If a <> 15 And a <> 19 And a <> 21 Then
       Sheets(i).Range("c" & a) = Sheets(i).Range("c" & a) + Workbooks(dirname).Sheets(i).Range("c" & a) '  本月
       Sheets(i).Range("d" & a) = Sheets(i).Range("d" & a) + Workbooks(dirname).Sheets(i).Range("d" & a) '  累计
      End If
    Next




   End If
  End With

Next

            Workbooks(dirname).Close False
        End If


        dirname = Dir
    Loop

       MsgBox "恭喜全部合并成功！", 64 + 0, "温馨提示"

End Sub

[本日志由 zilong 于 2008-12-16 04:30 PM 编辑]