有偿求助计算月度数据汇总

hzs1111111

求助高手，通过下载下来的1个月的明细表和手动填写的时间人员表来实现vba一键得到每个人的月度的销售额等数据，有偿求助，红包88元，希望得到高手帮助（加我qq：290075397），为避免误会以第一个发给我的测试没有问题的老哥为准吧，感谢感谢！！！！！

lizhipei78

在数据明细工作簿中，哪个时间段是对应的姓名A B C D的

hzs1111111

lizhipei78 发表于 2024-2-15 15:27
在数据明细工作簿中，哪个时间段是对应的姓名A B C D的

数据明细表中只有时间段数据没有姓名，需要根据手填的姓名去匹配明细表里面此人在此时间段的各项数据

lizhipei78

看了一下，你这个不算得太难，就是根据你提供手动录入的时间数值去对比明细表就可以了，只要明细表中的时间在手动录入的范围内就属于这个人的，就是ABCD四个人吧，如果还有其它更多的话，比较就会多很多

hzs1111111

lizhipei78 发表于 2024-2-15 15:53
看了一下，你这个不算得太难，就是根据你提供手动录入的时间数值去对比明细表就可以了，只要明细表中的时间 ...

人员可能会不固定 最多也不会超过10来个吧  以左边的人员来生成汇总表格即可

3190496160

因为此表是手填的可能时间上会有些许出入，比如当天第一个时间段的开播时间是10:31开始的，但是有可能手动填写成了10:20，但是播出时长的计算以明细表的10:31为准，每天的最后一个时间同理以明细为准

最关键的就是这点了，要有一个偏差范围才行吧？比如，偏差在几分钟范围内，不然，还真是没法准确判断究竟是谁的

hzs1111111

3190496160 发表于 2024-2-15 16:46
因为此表是手填的可能时间上会有些许出入，比如当天第一个时间段的开播时间是10:31开始的，但是有可能手动 ...

中间的时间不会偏差，会进行人工手动校正，  只是每天第一个时间和第最后一个时间会有偏差

fzxba

1. Sub test1() '
   
2.   
   
3.   Dim ar, br, cr, Conn As Object, Dict As Object
   
4.   Dim strConn As String, strSQL As String, p As String, f As String, s As String
   
5.   Dim i As Long, j As Long, pos As Long, x As Long, y As Long
   
6.   
   
7.   'Application.ScreenUpdating = False
   
8.   
   
9.   s = "Excel 12.0;HDR=YES;Database="
   
10.   If Application.Version < 12 Then
    
11.     s = Replace(s, "12.0", "8.0")
    
12.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source="
    
13.   Else
    
14.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source="
    
15.   End If
    
16.   
    
17.   Set Dict = CreateObject("Scripting.Dictionary")
    
18.   Set Conn = CreateObject("ADODB.Connection")
    
19.   Conn.Open strConn & ThisWorkbook.FullName
    
20.   
    
21.   p = ThisWorkbook.Path & "\"
    
22.   f = Dir(p & "*.xls*")
    
23.   
    
24.   While Len(f)
    
25.     If p & f <> ThisWorkbook.FullName Then
    
26.       strSQL = "SELECT CDATE(时间) AS 时间,成交金额,新增粉丝数,评论次数 FROM [" & s & p & f & "].[分钟级$A1:I] WHERE 时间 IS NOT NULL"
    
27.       Dict.Add strSQL, vbNullString
    
28.     End If
    
29.     f = Dir
    
30.   Wend
    
31.   strSQL = "SELECT * FROM (" & Join(Dict.Keys, " UNION ALL ") & ") WHERE 时间 BETWEEN #[A]# AND #[B]#"
    
32.   Dict.RemoveAll
    
33.   
    
34.   With Range("G1").CurrentRegion
    
35.     .Offset(2, 1).ClearContents
    
36.     ar = .Value
    
37.   End With
    
38.   For i = 3 To UBound(ar)
    
39.     Dict.Add ar(i, 1), i
    
40.   Next
    
41.   
    
42.   br = Range("A1").CurrentRegion
    
43.   For i = 2 To UBound(br)
    
44.     If Dict.Exists(br(i, 3)) Then
    
45.       pos = Dict(br(i, 3))
    
46.       cr = Conn.Execute(Replace(Replace(strSQL, "[A]", CDate(br(i, 1))), "[B]", CDate(br(i, 2)))).GetRows
    
47.       ar(pos, 2) = ar(pos, 2) + DateDiff("N", cr(0, 0), cr(0, UBound(cr, 2)))
    
48.       For x = 0 To UBound(cr, 2)
    
49.         For y = 1 To UBound(cr)
    
50.           ar(pos, y + 2) = ar(pos, y + 2) + Val(Replace(cr(y, x), ChrW(165), ""))
    
51.         Next
    
52.       Next
    
53.     End If
    
54.   Next
    
55.   
    
56.   With Range("G1").CurrentRegion
    
57.     .Columns(2).NumberFormatLocal = "0分"
    
58.     .Value = ar
    
59.   End With
    
60.   
    
61.   Conn.Close
    
62.   Set Conn = Nothing
    
63.   Set Dict = Nothing
    
64.   
    
65.   Application.ScreenUpdating = True
    
66.   Beep
    
67. End Sub

复制代码

fzxba

测试.rar (105.92 KB, 下载次数: 17)

2024-2-15 16:54 上传

点击文件名下载附件

hzs1111111

fzxba 发表于 2024-2-15 16:54

好的，感谢大佬，我测试一下