ExcelHome技术论坛

 找回密码
 免费注册
QQ登录 只需一步,快速开始
   
高效办公必会的Office99uu优优 永久免费,网表让Excel秒变数据库 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! 国内首部Excel函数公式学习大典 职场充电黑科技, Office微99uu优优 免费下载Excel行业应用视频
300集Office 2010微99uu优优 Tableau-数据可视化工具 突破Excel限制,用活字格提高效率 12门Excel免费公开课任你学
你的Excel 201099uu优优学习锦囊 欲罢不能, 过目难忘的 Office 新界面 免费的Excel考勤计算系统
查看: 305|回复: 19
打印 上一主题 下一主题

[求助] 如何用VBA字典实现如下的汇总

[复制链接]
TA的精华主题TA的得分主题
跳转到指定楼层
1
发表于 2018-1-13 23:35 | 只看该作者 |只看大图 回帖奖励 |倒序浏览 |阅读模式
本帖最后由 Banie_Liang 于 2018-1-14 08:38 编辑

求大神帮忙汇总下如下数据,附件已上传,谢谢


Book1.zip (7.03 KB, 下载次数: 20)
分享到:  QQ好友和群QQ好友和群 QQ空间QQ空间 腾讯微博腾讯微博 腾讯朋友腾讯朋友
收藏收藏3 分享分享 有用有用 无用无用
TA的精华主题TA的得分主题
2
 楼主| 发表于 2018-1-13 23:36 | 只看该作者 |楼主
附件附件。
TA的精华主题TA的得分主题
3
 楼主| 发表于 2018-1-14 08:39 | 只看该作者 |楼主
TA的精华主题TA的得分主题
4
发表于 2018-1-14 08:44 | 只看该作者
  •     Str_coon = "HDR=yes';Data Source =" & ThisWorkbook.FullName     '//OFFICE2003,2007 通用
  •    
  •     StrSQL = "SELECT DISTINCT Items"
  •     StrSQL = StrSQL & " FROM [" & SH0.Name & "$A2:D]"
  •     StrSQL = StrSQL & " WHERE NOT Items IS NULL AND LEN(Items)>0"
  •    
  •     ARX = GET_SQL_To_Arr(StrSQL, Str_coon, False)
  •    
  •     StrSQL = ""
  •     StrSQL = StrSQL & "SELECT test,Detail"
  •     For I = 0 To UBound(ARX, 1)
  •         StrSQL = StrSQL & ",SUM(IIF(Items='" & ARX(I, 0) & "',1,0)) AS [" & ARX(I, 0) & "]"
  •     Next
  •     StrSQL = StrSQL & ",SUM(数量) AS 合计"
  •     StrSQL = StrSQL & " FROM [" & SH0.Name & "$A2:D]"
  •     StrSQL = StrSQL & " WHERE NOT Items IS NULL AND LEN(Items)>0"
  •     StrSQL = StrSQL & " GROUP BY test,Detail"
  •    
  •     SQLARR = GET_SQL_To_Arr(StrSQL, Str_coon, True)
  •     SH1.Cells.ClearContents
  •     SH1.Range("A1").Resize(UBound(SQLARR, 1) + 1, UBound(SQLARR, 2) + 1) = SQLARR
  • 复制代码
    TA的精华主题TA的得分主题
    5
    发表于 2018-1-14 08:45 | 只看该作者
    Book1.rar (21.26 KB, 下载次数: 24)

    完整代码见附件
    TA的精华主题TA的得分主题
    6
    发表于 2018-1-14 09:20 | 只看该作者
    这样的我一般用三个字典,一个记录横表头,一个记录竖表头,一个记录数量
    TA的精华主题TA的得分主题
    7
    发表于 2018-1-14 09:27 | 只看该作者
    Option Explicit

    Sub test()
      Dim dic(1 To 2), arr, i, brr, n, j
      For i = 1 To UBound(dic)
        Set dic(i) = CreateObject("scripting.dictionary")
      Next
      ReDim n(1 To UBound(dic))
      arr = Range("b4:e" & Cells(Rows.Count, "b").End(xlUp).Row)
      For i = 1 To UBound(arr, 1)
        If Not dic(1).exists(arr(i, 1)) Then n(1) = n(1) + 1: dic(1)(arr(i, 1)) = n(1)
        If Not dic(2).exists(arr(i, 2)) Then n(2) = n(2) + 1: dic(2)(arr(i, 2)) = n(2)
      Next
      ReDim brr(1 To dic(2).Count, 1 To dic(1).Count + 3)
      For i = 1 To UBound(arr, 1)
        brr(dic(2)(arr(i, 2)), 1) = arr(i, 2): brr(dic(2)(arr(i, 2)), 2) = arr(i, 3)
        brr(dic(2)(arr(i, 2)), dic(1)(arr(i, 1)) + 2) = brr(dic(2)(arr(i, 2)), dic(1)(arr(i, 1)) + 2) + arr(i, 4)
      Next
      For i = 1 To UBound(brr, 1)
        For j = 3 To dic(1).Count + 2
          brr(i, UBound(brr, 2)) = brr(i, UBound(brr, 2)) + Val(brr(i, j))
      Next j, i
      [g5].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
    End Sub
    TA的精华主题TA的得分主题
    8
    发表于 2018-1-14 09:34 | 只看该作者
    本帖最后由 活在理想的世界 于 2018-1-14 09:46 编辑

  • Sub d()
  • Dim arr(), brr(), D1 As Object, D2 As Object
  • Set D1 = CreateObject("Scripting.Dictionary"): Set D2 = CreateObject("Scripting.Dictionary"): arr = Range("b3").CurrentRegion
  • For i = 2 To UBound(arr)
  •     D1(arr(i, 1)) = "": D2(arr(i, 2) & "*" & arr(i, 3)) = ""
  • Next
  • ReDim brr(1 To D2.Count, 1 To D1.Count + 3)
  • For Each i In D1.Keys
  • c = c + 1: r = 0
  •     For Each ii In D2.Keys
  •     r = r + 1
  •         For j = 2 To UBound(arr)
  •             If i & ii = arr(j, 1) & arr(j, 2) & "*" & arr(j, 3) Then
  •                 brr(r, c + 2) = brr(r, c + 2) + arr(j, 4)
  •             End If
  •         Next
  •     Next
  • Next
  • For Each i In D2.Keys
  • s = s + 1: brr(s, 1) = Split(i, "*")(0): brr(s, 2) = Split(i, "*")(1): brr(s, 8) = brr(s, 3) + brr(s, 4) + brr(s, 5) + brr(s, 6) + brr(s, 7)
  • Next
  • Range("i4").Resize(1, D1.Count) = D1.Keys: Range("g5").Resize(D2.Count, 8) = brr
  • End Sub
  • 复制代码

    TA的精华主题TA的得分主题
    9
    发表于 2018-1-14 15:07 | 只看该作者
    字典+SQL练习一下!
    Adele-透视表汇总.zip 28.73 KB, 下载次数: 8
    TA的精华主题TA的得分主题
    10
    发表于 2018-1-14 15:59 | 只看该作者
    Sub SQL加arr()
        Dim conn As Object, rst As Object, sql$, arr, brr()
        Set conn = CreateObject("adodb.connection")
        Set rst = CreateObject("ADODB.recordset")
        conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;extended properties=excel 12.0;data source=" & ThisWorkbook.FullName
        sql = "transform sum(数量) select test,Detail from [Sheet1$b3:e] where test<>'' group by test,Detail pivot Items"
        Set rst = conn.Execute(sql): arr = rst.GetRows
        ReDim brr(1 To UBound(arr, 2) + 2, 1 To UBound(arr) + 2)
        For Each Field In rst.Fields
            i = i + 1: brr(1, i) = Field.Name
        Next
        brr(1, i + 1) = "汇总"
        For j = 0 To UBound(arr, 2)
            For i = 0 To UBound(arr)
                brr(j + 2, i + 1) = arr(i, j)
                If i > 1 Then
                    brr(j + 2, UBound(arr) + 2) = brr(j + 2, UBound(arr) + 2) + IIf(IsNull(arr(i, j)), 0, arr(i, j))
                End If
            Next
        Next
        Range("g4").Resize(UBound(brr), UBound(brr, 2)) = brr
    End Sub

    点评

    看看有没有办法一步到位?  发表于 2018-1-14 16:51

    评分

    参与人数 1技术 +1 收起 理由
    jsgj2023 + 1 值得肯定
    查看全部评分
    您需要登录后才可以回帖 登录 | 免费注册
    本版积分规则
    关闭

    最新热点上一条 /1 下一条

    关注官方微信,每天坐享新鲜教程
    手机版|关于我们|联系我们|ExcelHome    GMT+8, 2018-1-18 19:36 , Processed in 0.606967 second(s), 14 queries , Gzip On, MemCache On.
    Powered by Discuz! X3.3 © 2001-2017 Wooffice Inc.
        沪公网安备 31011702000001号 沪ICP备11019229号 本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师
    快速回复 返回顶部 返回列表
    99uu优优