如何复制每个分表中的一列数据到汇总表，并对数据进行汇总

liurongyue

因工作需要，需要对下属单位的报表数据（其中一列数据）复制到汇总表，并进行汇总，由于是初学者还有很多不懂，请哪位高手帮忙改一下，谢谢！
合并表.rar (19.21 KB, 下载次数: 30)

2014-11-19 21:52 上传

点击文件名下载附件

LangQueS

"    楼主在设计数据表时，未考虑到充分发挥Excel软件的内置功能，对以后数据的积累、修改、引用和汇总造成了很大困难……
    建议楼主参考下帖附件中的文字说明，修改工作表的设置，首先建立好记录日常所发生数据的“一维数据表”。我们的目的是使用好Excel，实现对数据的管理，而不是制作软件。因此要充分发挥 Excel 自带的强大功能，例如“高级筛选”、“数据透视表”等等，再用函数和代码等方法作为补充，以降低制作和修改难度，提高工作效率。
    以上浅见是个人观点，不代表论坛立场。"

★Excel数据管理的一般规律★    http://club.excelhome.net/thread-287461-1-1.html

liurongyue

感谢指教，由于时间来不及，只能先找个现成的先用，只有以后再再考虑数据管理的问题。

魂断蓝桥

Sub a()
Dim cnn As Object, rs As Object, SQL$, Mypath$, MyName$, arr, brr(1 To 30000, 1 To 1), i, m As Integer, d
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Mypath = ThisWorkbook.Path & "\"
MyName = Dir(Mypath & "*.xls")
Do While MyName <> ""
    If MyName <> ThisWorkbook.Name Then
        Set cnn = CreateObject("ADODB.Connection")
        cnn.Open "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=NO';Data Source=" & Mypath & MyName
        SQL = "select * from [sheet1$a4:b10] "
        Set rs = cnn.Execute(SQL)
        arr = rs.getRows
            For i = 0 To UBound(arr, 2)
                m = m + 1
                brr(m, 1) = arr(0, i)
                d(brr(m, 1)) = d(brr(m, 1)) + arr(1, i)
            Next
    End If
    MyName = Dir()
Loop
[a4].Resize(d.Count, 1) = Application.Transpose(d.keys)
[b4].Resize(d.Count, 1) = Application.Transpose(d.items)
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
Set d = Nothing
Application.ScreenUpdating = True
End Sub

zax010

Sub zz()
    Dim f$, p$, wb As Workbook, s As Range
    Application.ScreenUpdating = False
    Set wb = ThisWorkbook
    p = ThisWorkbook.Path & "\"
    f = Dir(p & "*.xls")
    Do While Len(f)
        If f <> ThisWorkbook.Name Then
            With GetObject(p & f)
                a = .Sheets(1).Range("B4:B" & .Sheets(1).[b65536].End(3).Row)
                b = Split(f, ".")(0)
                .Close False
            End With
            With wb.Sheets("Sheet1")
                Set s = .Rows("3").Find(b)
                s.Offset(1, 0).Resize(UBound(a)) = a
            End With
            Erase a
        End If
        f = Dir
    Loop
    With Sheet1
        For i = 4 To .[a65536].End(3).Row
            For j = 2 To Sheet2.[iv3].End(xlToLeft).Column
                .Cells(i, 2) = .Cells(i, 2) + Sheet2.Cells(i, j)
            Next
        Next
    End With
    Application.ScreenUpdating = True
End Sub

zax010

>>>>>>>>>>>>>>>>>>>
合并表.rar (21.16 KB, 下载次数: 76)

2014-11-20 11:57 上传

点击文件名下载附件

kszcs

zax010 发表于 2014-11-20 11:57
>>>>>>>>>>>>>>>>>>>

增加工作簿，代码能自动增加单位名并继续汇总吗？
谢谢！

zax010

kszcs 发表于 2014-11-21 21:34
增加工作簿，代码能自动增加单位名并继续汇总吗？
谢谢！

Sub zz()
    Dim f$, p$, wb As Workbook
    Application.ScreenUpdating = False
    Set wb = ThisWorkbook
    p = ThisWorkbook.Path & "\"
    f = Dir(p & "*.xls")
    wb.Sheets("sheet1").[b3].Resize(9, 100).ClearContents
    wb.Sheets("汇总表").[b4:b11].ClearContents
    Do While Len(f)
        If f <> ThisWorkbook.Name Then
            With GetObject(p & f)
                a = .Sheets(1).Range("B4:B" & .Sheets(1).[b65536].End(3).Row)
                b = Split(f, ".")(0)
                .Close False
            End With
            With wb.Sheets("Sheet1")
                .Cells(3, 2 + n) = b
                .Cells(3, 2 + n).Offset(1, 0).Resize(UBound(a)) = a: n = n + 1
            End With
            Erase a
        End If
        f = Dir
    Loop
    With Sheet1
        For i = 4 To .[a65536].End(3).Row
            For j = 2 To Sheet2.[iv3].End(xlToLeft).Column
                .Cells(i, 2) = .Cells(i, 2) + Sheet2.Cells(i, j)
            Next
        Next
    End With
    Application.ScreenUpdating = True
End Sub

zax010

kszcs 发表于 2014-11-21 21:34
增加工作簿，代码能自动增加单位名并继续汇总吗？
谢谢！

>>>>>>>>>>>>>>>>>>>>>>>

zax010

kszcs 发表于 2014-11-21 21:34
增加工作簿，代码能自动增加单位名并继续汇总吗？
谢谢！

>>>>>>>>>>>>>>>>>>>>>>>
合并表.rar (31.8 KB, 下载次数: )

2014-11-22 11:13 上传

点击文件名下载附件