求大师完善跨工作簿提数据并求和代码

同心/ty

longming3 发表于 2023-5-27 09:52
不知道能不能解决你的问题，记得送上免费的花花

谢谢老师，使用你的代码我统计表需要增设列，同时统计结果也加了公式，我数据量大增列不方便哟，能否在增列的条件下作跨表统计。

不知道为什么

同心/ty 发表于 2023-5-27 10:40
老师，我测试了18楼代码，能完成我要的效果，但不友好的地方是要增设辅助列6列，我表中F列-N列是有数据的 ...

那 你把18楼老师 提示选择文件的代码复制过来 就满足你需求了啊

同心/ty

不知道为什么 发表于 2023-5-27 10:53
那 你把18楼老师 提示选择文件的代码复制过来 就满足你需求了啊

我复制过去，运行提示有错误。

不知道为什么

同心/ty 发表于 2023-5-27 11:03
我复制过去，运行提示有错误。

。。。。。。。。。

Desktop.zip (44.6 KB, 下载次数: 9)

2023-5-27 11:23 上传

点击文件名下载附件

同心/ty

不知道为什么 发表于 2023-5-27 11:23
。。。。。。。。。

谢谢!谢谢!

longming3

同心/ty 发表于 2023-5-27 10:43
谢谢老师，使用你的代码我统计表需要增设列，同时统计结果也加了公式，我数据量大增列不方便哟，能否在增 ...

代码结果中统计表是按你设计好的表格格式做的，你增加或减少列都可以，代码中稍微修改一下就可以了。
代码中ar就是统计表的格式大小，增加减少列，调整对应的6、7这些数字即可，6就是第6列，7就是第7列。同理，br是基础表的格式大小，列数变化也是对应修改5、6这样的数字。统计表最后一列是读取的哪个表的表名，便于知道数据源是哪张表，如果不需要，直接在代码中把ar(d(gjz)),16)删掉即可，16表示第16列的数据。

longming3

只要计算结果改成这样即可

同心/ty

经过多位老师的帮助，在此表示感谢。最终代码附上。


Sub myTest()
    Dim arr, dic, i%, j%, s#, r%, brr
    Set dic = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   file = Application.GetOpenFilename(filefilter:="EXCEL 工作表(*.xlsx;*.xlsm;*.xls),*.xlsx;*.xlsm;*.xls")
    If file <> False Then
        With Workbooks.Open(file)
            With .ActiveSheet
                r = .Cells(.Rows.Count, "G").End(xlUp).Row - 6
                arr = .[g7].Resize(r, 14)
            End With
            .Close False
        End With
        For i = 1 To UBound(arr)
            If Len(Trim(arr(i, 1))) Then
                For j = 9 To 14
                    s = s + arr(i, j)
                Next j
                dic(Trim(arr(i, 1))) = dic(Trim(arr(i, 1))) + s: s = 0
            End If
        Next i
        With Sheet1
            arr = .Range("e7:e" & .Cells(.Rows.Count, "e").End(xlUp).Row)
            ReDim brr(1 To UBound(arr), 1 To 1)
            For i = 1 To UBound(arr)
                If dic.exists(Trim(arr(i, 1))) Then brr(i, 1) = dic(Trim(arr(i, 1)))
            Next i
            With .[o7].Resize(UBound(arr), 1)
                .ClearContents
                .Value = brr
            End With
        End With
    Else
        MsgBox "没有选定工作薄！～": Exit Sub
    End If
    Set dic = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

同心/ty

谢谢Longming3老师，代码测试成功，附上学习。

Sub test1()
    Application.ScreenUpdating = False '关闭屏幕更新
    Range("O7:O3000").Select
    Selection.ClearContents
   
    Set d = CreateObject("Scripting.Dictionary")
    With Sheets("Sheet1")
        m = .[d65536].End(3).Row
        ar = .Range("a7").Resize(m - 6, 16)
        For i = 1 To UBound(ar)
            If Len(ar(i, 4)) Then
                gjz = ar(i, 4) & ar(i, 5) '关键字为姓名+身份证号
                d(gjz) = i '记录行号
            End If
        Next
   
   
        Dim files
        Dim wb As Workbook
        Dim sht As Worksheets
        files = Application.GetOpenFilename(filefilter:="EXCEL 工作表(*.xlsx;*.xlsm;*.xls),*.xlsx;*.xlsm;*.xls", Title:="请选择要导入的工作簿", MultiSelect:=True) '选取，可以选多个excel文件
        If Not IsArray(files) Then '如果按取消，没有选择的时候，退出程序
            MsgBox "没有选定工作薄！～"
            Exit Sub
        End If
        For i = UBound(files) To LBound(files) Step -1 '循环
            Set wb = Workbooks.Open(files(i)) '依次打开
            With wb.ActiveSheet
                m = .[f65536].End(3).Row
                br = .Range("a7").Resize(m - 6, 21)
                For j = 1 To UBound(br)
                    If Len(br(j, 6)) Then
                        gjz = br(j, 6) & br(j, 7)
                        If d.exists(gjz) Then
                        For k = 15 To 20
                           ar(d(gjz), 15) = ar(d(gjz), 15) + Val(br(j, k))
                           Next
                        End If
                    End If
                Next
            End With
            wb.Close False
        Next
        
        .Range("a7").Resize(UBound(ar), UBound(ar, 2)) = ar
    End With
    Application.ScreenUpdating = True    '打开屏幕更新
End Sub

同心/ty

longming3 发表于 2023-5-27 11:39
只要计算结果改成这样即可

老师，测试成功，在你代码前我加了单元格清除码。实现现清除再写入数据。谢谢！