真诚请教家里大神,vba字典数组多表格求和

幽默的熊

实战中还是遇到了麻烦, 想求助家里的大神大佬们!!!

是根据id和日期, 仅把sheet1 2 3 的金额, 求和计算到sheet"求和"的金额列;

实战中干扰列,干扰sheet都有, ID要文本格式, 金额是数字格式

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.7.29
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set sh = ThisWorkbook.Sheets("求和")
   
5.     On Error Resume Next
   
6.     For Each sht In Sheets
   
7.         If Val(sht.Name) Then
   
8.             With sht
   
9.                 r = .Cells(Rows.Count, 1).End(3).Row
   
10.                 c = .UsedRange.Columns.Count
    
11.                 c1 = Application.WorksheetFunction.Match(UCase("ID"), .Rows(1), 0)
    
12.                 c2 = Application.WorksheetFunction.Match("日期", .Rows(1), 0)
    
13.                 c3 = Application.WorksheetFunction.Match("金额", .Rows(1), 0)
    
14.                 arr = .[a1].Resize(r, c)
    
15.             End With
    
16.             For i = 2 To UBound(arr)
    
17.                 s = CStr(arr(i, c1)) & "|" & Format(arr(i, c2), "yyyy-mm-dd")
    
18.                 d(s) = d(s) + arr(i, c3)
    
19.             Next
    
20.         End If
    
21.     Next
    
22.     With sh
    
23.         r = .Cells(Rows.Count, 1).End(3).Row
    
24.         arr = .[a1].Resize(r, 3)
    
25.         For i = 2 To UBound(arr)
    
26.         rq = CDate(arr(i, 1))
    
27.             s = CStr(arr(i, 2)) & "|" & arr(i, 1)
    
28.             If d.exists(s) Then
    
29.                 arr(i, 3) = d(s)
    
30.             End If
    
31.         Next
    
32.         .[c1].Resize(r, 1) = Application.Index(arr, 0, 3)
    
33.     End With
    
34.     Set d = Nothing
    
35.     Application.ScreenUpdating = True
    
36.     MsgBox "OK！"
    
37. End Sub
    
38. 
    
39. 
    

复制代码

cidanji

limonet

关键字：for each+if+union all+group+right join

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, Sht As Worksheet
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    For Each Sht In Worksheets
        If Sht.Name <> "无用表" And Sht.Name <> "求和" Then
            StrSQL = StrSQL & " Union All Select id,金额,日期 From [" & Sht.Name & "$]"
        End If
    Next Sht
    StrSQL = "Select id,Sum(金额) As 金额,日期 From (" & Mid(StrSQL, 12) & ") Group By id,日期"
    StrSQL = "Select 金额 From (" & StrSQL & ")a Right Join [求和$A:B]b On a.id=b.id And a.日期=b.日期"
    Range("C2").CopyFromRecordset Cn.Execute(StrSQL)
End Sub

jjmysjg

cidanji 发表于 2024-7-29 10:42

自动提取不重复ID和时间

幽默的熊

ykcbf1100 发表于 2024-7-29 10:29
参与一下。。。

我把sheet1 换成40万行数据量, 1.17秒就算完了, 大佬牛逼, 有学到了!!!!!!