求助，想合并多个excel每个excel有多个sheet，每个sheet单独合并 谢谢各位大神

凌空一羽

cqcbc 发表于 2020-1-22 19:08
麻烦大师将《21企业集团基本情况表》的代码给出来了一下，不知如何修改，有三个区域要统计，与已有的两个 ...

请参考附件……

cqcbc

凌空一羽 发表于 2020-1-22 20:15
请参考附件……

谢谢，学习了，加上清除原有汇总后的数据，可以再次汇总了。

'http://club.excelhome.net/forum.php?mod=viewthread&tid=1517532
Sub lkyy修改()
        Dim Mf, Mp$, sht As Worksheet, ar(1 To 24, 1 To 2)
    Dim r As Range
   
    Sheets("01资产负债").Range("c5:d77,g5:h77").ClearContents
    Sheets("02利润").Range("c5:d40,g5:h40").ClearContents
    Sheets("03现金流").Range("c5:d34,g5:h34").ClearContents
    Sheets("04所有者权益").Range("c9:ad41").ClearContents
    Sheets("05国有资产变动").Range("c5:c20,f5:f20").ClearContents
    Sheets("06-减值准备").Range("c7:m26,p7:p26").ClearContents
    Sheets("07应上交应弥补款项表 ").Range("c5:d27,g5:g27").ClearContents
    Sheets("08基本情况表").Range("c5:d34,g5:h34").ClearContents
    Sheets("09人力资源情况表").Range("c5:d25,g5:h25").ClearContents
    Sheets("10带息负债").Range("c7:i32,l7:m32").ClearContents
    Sheets("11应收").Range("c8:h30,k8:m30").ClearContents
    Sheets("12存货").Range("c7:f16,i7:j16").ClearContents
    Sheets("13对外股投").Range("c7:u25").ClearContents
    Sheets("14并购").Range("c7:w23").ClearContents
    Sheets("15股权处置").Range("c6:k28").ClearContents
    Sheets("16金融投资及风险").Range("c7:d39,g7:g39").ClearContents
    Sheets("17资金集中").Range("c5:d25").ClearContents
    Sheets("18担保").Range("c7:s22").ClearContents
    Sheets("19主要业务").Range("c8:w28").ClearContents
    Sheets("20成本费用").Range("c5:d27,g5:h27,K5:L27").ClearContents
    Sheets("21企业集团基本情况表").Range("c5:d37,g5:h37,k5:l37").ClearContents
    Sheets("22未纳入").Range("c7:t23").ClearContents
    Sheets("23股权结构 ").Range("b6:j17").ClearContents
    Sheets("24期初数调整").Range("c8:s19").ClearContents
   
   
    Mp = ThisWorkbook.Path & "\"
    Mf = Dir(Mp & "*.xlsx")
    ar(1, 1) = "01": ar(1, 2) = "c5:d77,g5:h77"
    ar(2, 1) = "02": ar(2, 2) = "c5:d40,g5:h40"
    ar(3, 1) = "03": ar(3, 2) = "c5:d34,g5:h34"
    ar(4, 1) = "04": ar(4, 2) = "c9:ad41"
    ar(5, 1) = "05": ar(5, 2) = "c5:c20,f5:f20"
    ar(6, 1) = "06": ar(6, 2) = "c7:m26,p7:p26"
    ar(7, 1) = "07": ar(7, 2) = "c5:d27,g5:g27"
    ar(8, 1) = "08": ar(8, 2) = "c5:d34,g5:h34"
    ar(9, 1) = "09": ar(9, 2) = "c5:d25,g5:h25"
    ar(10, 1) = "10": ar(10, 2) = "c7:i32,l7:m32"
    ar(11, 1) = "11": ar(11, 2) = "c8:h30,k8:m30"
    ar(12, 1) = "12": ar(12, 2) = "c7:f16,i7:j16"
    ar(13, 1) = "13": ar(13, 2) = "c7:u25"
    ar(14, 1) = "14": ar(14, 2) = "c7:w23"
    ar(15, 1) = "15": ar(15, 2) = "c6:k28"
    ar(16, 1) = "16": ar(16, 2) = "c7:d39,g7:g39"
    ar(17, 1) = "17": ar(17, 2) = "c5:d25"
    ar(18, 1) = "18": ar(18, 2) = "c7:s22"
    ar(19, 1) = "19": ar(19, 2) = "c8:w28"
    ar(20, 1) = "20": ar(20, 2) = "c5:d27,g5:h27,K5:L27"
    ar(21, 1) = "21": ar(21, 2) = "c5:d37,g5:h37,k5:l37"
    ar(22, 1) = "22": ar(22, 2) = "c7:t23"
    ar(23, 1) = "23": ar(23, 2) = "b6:j17"
    ar(24, 1) = "24": ar(24, 2) = "c8:s19"
   
    Do While Mf <> ""
        'If Mf <> ThisWorkbook.Name Then
        If Mf <> ThisWorkbook.Name And InStr(Mf, "~$") = 0 Then  '排除~$文件
            With Workbooks.Open(Mp & Mf)
                For Each sht In .Worksheets
                    If sht.Name <> "财务情况表" Then
                    
                        'If Left(sht.Name, 2) / 1 < 22 Or Left(sht.Name, 2) / 1 > 22 Then  '只统计前后指定表，你加上代码之后，就可以删除这个if
                        For Each r In sht.Range(ar(Left(sht.Name, 2) / 1, 2))
                            If TypeName(r) <> "String" Then
                                ThisWorkbook.Sheets(sht.Name).Range(r.Address(0, 0)) = ThisWorkbook.Sheets(sht.Name).Range(r.Address(0, 0)) + r.Value
                            End If
                        Next r
                        'End If   '只统计前后各2张表，你加上之前，就可以删除这个if
                    End If  'sht.Name <> "财务情况表"
                Next sht
                .Close 0
            End With
        End If
        Mf = Dir()
    Loop
End Sub

凌空一羽

cqcbc 发表于 2020-1-23 08:15
谢谢，学习了，加上清除原有汇总后的数据，可以再次汇总了。

'http://club.excelhome.net/forum.php?m ...

Sub lkyy()
    Dim Mf, Mp$, sht As Worksheet, ar(1 To 24, 1 To 1)
    Dim r As Range
    Mp = ThisWorkbook.Path & "\"
    Mf = Dir(Mp & "*.xlsx")
    ar(1, 1) = "c5:d77,g5:h77"
    ar(2, 1) = "c5:d40,g5:h40"
    ar(3, 1) = "c5:d34,g5:h34"
    ar(4, 1) = "c9:ad41"
    ar(5, 1) = "c5:c20,f5:f20"
    ar(6, 1) = "c7:m26,p7:p26"
    ar(7, 1) = "c5:d27,g5:g27"
    ar(8, 1) = "c5:d34,g5:h34"
    ar(9, 1) = "c5:d25,g5:h25"
    ar(10, 1) = "c7:i32,l7:m32"
    ar(11, 1) = "c8:h30,k8:m30"
    ar(12, 1) = "c7:f16,i7:j16"
    ar(13, 1) = "c7:u25"
    ar(14, 1) = "c7:w23"
    ar(15, 1) = "c6:k28"
    ar(16, 1) = "c7:d39,g7:g39"
    ar(17, 1) = "c5:d25"
    ar(18, 1) = "c7:s22"
    ar(19, 1) = "c8:w28"
    ar(20, 1) = "c5:d27,g5:h27,K5:L27"
    ar(21, 1) = "c5:d37,g5:h37,k5:l37"
    ar(22, 1) = "c7:t23"
    ar(23, 1) = "c6:j17"
    ar(24, 1) = "c8:s19"

    For i = 1 To Sheets.Count
        If Sheets(i).Name <> "财务情况表" Then
            Sheets(i).Range(ar(Left(Sheets(i).Name, 2) / 1, 1)).ClearContents
        End If
    Next

Do While Mf <> ""
    If Mf <> ThisWorkbook.Name Then
        With Workbooks.Open(Mp & Mf)
            For Each sht In .Worksheets
                If sht.Name <> "财务情况表" Then
                    For Each r In sht.Range(ar(Left(sht.Name, 2) / 1, 1))
                        If IsNumeric(r) Then
                            ThisWorkbook.Sheets(sht.Name).Range(r.Address(0, 0)) = ThisWorkbook.Sheets(sht.Name).Range(r.Address(0, 0)) + r.Value
                        End If
                    Next r
                End If  'sht.Name <> "财务情况表"
            Next sht
            .Close 0
        End With
    End If
    Mf = Dir()
Loop
End Sub

cqcbc

凌空一羽 发表于 2020-1-23 12:19
Sub lkyy()
    Dim Mf, Mp$, sht As Worksheet, ar(1 To 24, 1 To 1)
    Dim r As Range

学习了清除选定区域数据的写法以及检测变量是否为数字或数字字符串的方法，谢谢。