多表汇总

yangqianming

在汇总文件夹下有一个得分表文件夹，得分表文件夹有多个文件（个数不定），
每个文件表中都有姓名，得分、金额字段，其它字段不确定，在汇总文件夹有

一个汇总表是空表（里面数据是我模拟结果），需要把得分表文件夹中的得分
和金额汇总到汇总表里，汇总表的姓名列应该是分表的姓名不重复值。能否请
老师们帮我做一下，谢谢！
汇总.rar (29.97 KB, 下载次数: 19)

2023-12-15 14:50 上传

点击文件名下载附件

zpy2

https://club.excelhome.net/forum.php?mod=viewthread&tid=1679471&page=1&mobile&_dsign=772c0d77

chxw68

参与一下。

cyq4896

参与一下..

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2023.12.15
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Set sh = ThisWorkbook.Sheets("汇总表")
   
6.     p = ThisWorkbook.Path & "\得分表"
   
7.     For Each f In fso.GetFolder(p).Files
   
8.         If f.Name Like "*.xls*" Then
   
9.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
   
10.                 fn = fso.GetBaseName(f)
    
11.                 Set Wb = Workbooks.Open(f, 0)
    
12.                 With Wb.Sheets(1)
    
13.                     r = .Cells(Rows.Count, 1).End(3).Row
    
14.                     c1 = .Rows(1).Find("得分", , , , , 1).Column
    
15.                     c2 = .Rows(1).Find("金额", , , , , 1).Column
    
16.                     arr = .Range("a1", .Cells(r, c2))
    
17.                 End With
    
18.                 Wb.Close False
    
19.                 For i = 2 To UBound(arr)
    
20.                     s = arr(i, 1)
    
21.                     If Not d.exists(s) Then
    
22.                         d(s) = Array(s, arr(i, c1), arr(i, c2))
    
23.                     Else
    
24.                         t = d(s)
    
25.                         t(1) = t(1) + arr(i, c1)
    
26.                         t(2) = t(2) + arr(i, c2)
    
27.                         d(s) = t
    
28.                     End If
    
29.                 Next
    
30.             End If
    
31.         End If
    
32.     Next f
    
33.     With sh
    
34.         .UsedRange.Offset(1).Clear
    
35.         With .[a2].Resize(d.Count, 3)
    
36.             .Value = Application.Rept(d.Items, 1)
    
37.             .Borders.LineStyle = 1
    
38.             .HorizontalAlignment = xlCenter
    
39.             .VerticalAlignment = xlCenter
    
40.         End With
    
41.         With .[b2].Resize(d.Count, 2)
    
42.             .HorizontalAlignment = xlRight
    
43.         End With
    
44.     End With
    
45.     Application.ScreenUpdating = True
    
46.     MsgBox "OK！"
    
47. End Sub
    

复制代码

ykcbf1100

附件供参考。。。

yangqianming

我还想着这个肯定难度很大，没想到chxw68、cyq4896、ykcbf1100很快给完美解决，看来在难的问题只要遇到热心的老师都不算啥，非常感谢各位帮助！

cjc209

jsa 代码
function test(){
        var file=IO.getFiles("C:\\Users\\Administrator\\Desktop\\汇总\\汇总\\得分表")
        var bt=["姓名","得分","金额"];
        var 结果表头=[["姓名","总分","总金额"]];
        var rs=[]
        for (var f of file){
                var wb = Workbooks.Open(f)
                var arr=Range("a1").CurrentRegion.Value2;
                var arr=selectCols_Z(arr,bt,0).skip_Z(1)
                wb.Close()
                rs=rs.concat(arr)
                }
                var jg=groupInto_Z(rs,"f1","sum('f2'),sum('f3')",0)
                结果表头.concat(jg).toRange_Z("Sheet1!f1")
}

yangqianming

cjc209 发表于 2023-12-15 16:15
jsa 代码
function test(){
        var file=IO.getFiles("C:\%users\\Administrator\\Desktop\\汇总\\汇总\\得 ...

这个看着简单，应该很难想吧，我都不知道怎么使用这个代码

yizhimoshou

Sub UpdateSummary() '//2023.12.15
    Dim fso As Object
    Dim d As Object
    Dim sh As Worksheet
    Dim p As String
    Dim f As Object
    Dim Wb As Workbook
    Dim r As Long
    Dim c1 As Long, c2 As Long
    Dim arr As Variant
    Dim fn As String
    Dim i As Long
    Dim s As String, t As Variant

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set d = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
    Set sh = ThisWorkbook.Sheets("汇总表")
    p = ThisWorkbook.Path & "\得分表"

    For Each f In fso.GetFolder(p).Files
        If f.Name Like "*.xls*" Then
            If InStr(f.Name, ThisWorkbook.Name) = 0 Then
                fn = fso.GetBaseName(f)
                Set Wb = Workbooks.Open(f, 0)
                With Wb.Sheets(1)
                    r = .Cells(.Rows.Count, 1).End(xlUp).Row
                    c1 = .Rows(1).Find("得分", , , , , 1).Column
                    c2 = .Rows(1).Find("金额", , , , , 1).Column
                    arr = .Range("A1", .Cells(r, c2)).Value
                End With
                Wb.Close False

                For i = 2 To UBound(arr)
                    s = arr(i, 1)
                    If Not d.Exists(s) Then
                        d(s) = Array(s, arr(i, c1), arr(i, c2))
                    Else
                        t = d(s)
                        t(1) = t(1) + arr(i, c1)
                        t(2) = t(2) + arr(i, c2)
                        d(s) = t
                    End If
                Next
            End If
        End If
    Next f

    With sh
        .UsedRange.Offset(1).Clear
        With .Range("A2").Resize(d.Count, 3)
            .Value = Application.Rept(d.Items, 1)
            .Borders.LineStyle = 1
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
        With .Range("B2").Resize(d.Count, 2)
            .HorizontalAlignment = xlRight
        End With
    End With

    Application.ScreenUpdating = True
    Set fso = Nothing
    Set d = Nothing
    Set sh = Nothing
    Set Wb = Nothing
    MsgBox "OK！"
End Sub