关于字典与数组（二）

zymwhy

各位老师，我通过字典+数组模拟了提取多列汇总数据问题，请给予更加简便有效的解决办法，不胜感激。

xyxcc177

Sub test()
Dim cn As Object
Dim sql, str As String
Set cn = CreateObject("adodb.connection")
   str = "provider=microsoft.ace.oledb.12.0;Extended properties=Excel 12.0;data source=" & ThisWorkbook.FullName
cn.Open str
sql = "select 大区,部门,姓名,sum(北京) as 北京,sum(天津) as 天津,sum(上海) as 上海,sum(南京) as 南京 " _
   & "from [数据$] where 姓名 in(select 姓名 from [需要提取人员$]) group by 大区,部门,姓名"
Sheet3.Range("a2").CopyFromRecordset cn.Execute(sql)
cn.Close
End Sub

lsc900707

参考测试附件：

everbest2015

Option Explicit
Sub 汇总()
        Dim ar, d, i&, s$, br, t
        ar = Sheet1.Range("a1").CurrentRegion
        If Not IsArray(ar) Then Exit Sub
        Set d = CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(ar)
            s = ar(i, 1) & "☆" & ar(i, 2) & "☆" & ar(i, 3)
            If s <> "" Then
                If Not d.exists(s) Then
                    d(s) = Array(ar(i, 1), ar(i, 2), ar(i, 3), ar(i, 4), ar(i, 5), ar(i, 6), ar(i, 7))
                Else
                    br = d(s)
                    br(3) = br(3) + ar(i, 4)
                    br(4) = br(4) + ar(i, 5)
                    br(5) = br(5) + ar(i, 6)
                    br(6) = br(6) + ar(i, 7)
                    d(s) = br
                End If
            End If
        Next
    If d.Count > 0 Then
             t = d.items
             Sheet1.Range("J2:P" & d.Count + 1) = ""
             Sheet1.Range("J2:P" & d.Count + 1) = Application.Rept(t, 1)
             Set d = Nothing
            MsgBox "处理成功", , "提示"
       Else
        MsgBox "未处理任何数据,数据源中不存在任何数据", 64, "请核实您的数据"
    End If
End Sub

everbest2015

请参阅我的附件,后面两个表没用到,按自己的理解写了一个,直接一次把第一个表的数据全部处理了

chis3

你的寫法已經很標準,最多也是加個循環
再不是就sql了
你不想一一對列的意思是,你的列會變化?
如想自動對化也就一開始用match函數自動鎮定列,那增加減小行也會對位

zymwhy

everbest2015 发表于 2019-1-19 18:15
Option Explicit
Sub 汇总()
        Dim ar, d, i&, s$, br, t

Sheet1.Range("J2:P" & d.Count + 1) = ""
Sheet1.Range("J2:P" & d.Count + 1) = Application.Rept(t, 1)
首先谢谢您，码得这么祥细。这两句我就不明白了。留存消化。

zymwhy

谢谢所有给予回复指点人。