ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 923|回复: 9

[求助] 数据拆分汇总

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-1-22 03:53 | 显示全部楼层 |阅读模式
大家好,想大家求助如何对已有数据进行拆分汇总。具体如下,
有两列数据,分别为group和name。name指各个国家的名称,group指这个国家属于某个组织。
希望能够找出总共有几个group,然后将每个group对应的国家的name列举出来,要求国家的name不重复出现。
希望的结果展示,如O-U列所示:第一行为各个group,然后每一列为对应的国家的name。
十分感谢。



数据拆分.rar

7.93 KB, 下载次数: 17

TA的精华主题

TA的得分主题

发表于 2019-1-22 08:29 | 显示全部楼层
  1. Sub test()
  2.   Dim r%, i%
  3.   Dim arr, brr
  4.   Dim d As Object
  5.   Set d = CreateObject("scripting.dictionary")
  6.   With Worksheets("sheet1")
  7.     r = .Cells(.Rows.Count, 2).End(xlUp).Row
  8.     arr = .Range("b4:c" & r)
  9.     For i = 1 To UBound(arr)
  10.       If Not d.exists(arr(i, 1)) Then
  11.         m = 1
  12.         ReDim brr(1 To m)
  13.       Else
  14.         brr = d(arr(i, 1))
  15.         m = UBound(brr) + 1
  16.         ReDim Preserve brr(1 To m)
  17.       End If
  18.       brr(m) = arr(i, 2)
  19.       d(arr(i, 1)) = brr
  20.     Next
  21.     n = 15
  22.     For Each aa In d.keys
  23.       brr = d(aa)
  24.       .Cells(3, n) = aa
  25.       .Cells(4, n).Resize(UBound(brr), 1) = Application.Transpose(brr)
  26.       n = n + 1
  27.     Next
  28.   End With
  29. End Sub

复制代码

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2019-1-22 08:30 | 显示全部楼层
这个应该是分类汇总,不是数据拆分。

数据拆分.rar

24.8 KB, 下载次数: 21

TA的精华主题

TA的得分主题

发表于 2019-1-22 10:37 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
Sub 字典汇总()
    Dim arr, brr
    Set d = CreateObject("scripting.dictionary")
    Set d1 = CreateObject("scripting.dictionary")
    arr = Sheet1.[b4:c35] '数据装入数组
   
    For i = 1 To UBound(arr)
        tjz = arr(i, 1) '条件
        If d.Exists(tjz) Then '字典里存在的时候
        brr = d(tjz) '字典关键字对应的条目的值装入结果数组(可以为数组)
        If Not d1.Exists(tjz & arr(i, 2)) Then
           d1(tjz & arr(i, 2)) = ""
            brr(2) = brr(2) & "," & arr(i, 2) '要汇总的列
        End If
    Else
        ReDim brr(1 To UBound(arr, 2)) '声明动态数组 装符合条件的每列数据
        For l = 1 To UBound(arr, 2)
            brr(l) = arr(i, l) '需要的字段装入结果数组
        Next l
        d1(tjz & arr(i, 2)) = ""
    End If
    d(tjz) = brr '更新字典条目中的值
Next
If d.Count Then
    Sheet1.Range("o3").CurrentRegion.ClearContents '清除结果区的数据
'    brr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(d.Items)) '数组装置
    Sheet1.Range("o3").Resize(1, d.Count) = d.keys '赋值
    For Each ttt In d.keys
    l3 = l3 + 1
    zzz = d(ttt)
    jg = Split(zzz(2), ",")
   If UBound(jg) Then
    Cells(4, 14 + l3).Resize(UBound(jg), 1) = jg
    Else
    Cells(4, 14 + l3) = jg
    End If
    Next
   
End If
End Sub

TA的精华主题

TA的得分主题

发表于 2019-1-22 12:14 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
  1. Sub tt()
  2.     Set d = CreateObject("scripting.dictionary")
  3.     arr = Range("b4", [c4].End(4))
  4.     For i = 1 To UBound(arr)
  5.         d(arr(i, 1)) = d(arr(i, 1)) & "@" & arr(i, 2)
  6.     Next
  7.     ReDim brr(UBound(arr), d.Count - 1)
  8.     For Each x In d.keys
  9.         brr(0, k) = x
  10.         ar = Split(d.Item(x), "@")
  11.         For i = 1 To UBound(ar): brr(i, k) = ar(i): Next
  12.         k = k + 1
  13.     Next
  14.     [f8].Resize(UBound(arr), d.Count) = brr
  15. End Sub

复制代码

TA的精华主题

TA的得分主题

发表于 2019-1-22 12:21 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
结果横放真不适应,如果是竖着放,看着更舒服,改一下代码。
  1. Sub tt()
  2.     Set d = CreateObject("scripting.dictionary")
  3.     arr = Range("b4", [c4].End(4))
  4.     For i = 1 To UBound(arr)
  5.         d(arr(i, 1)) = d(arr(i, 1)) & "@" & arr(i, 2)
  6.     Next
  7.     ReDim brr(d.Count, UBound(arr))
  8.     For Each x In d.keys
  9.         brr(k, 0) = x
  10.         ar = Split(d.Item(x), "@")
  11.         For i = 1 To UBound(ar): brr(k, i) = ar(i): Next
  12.         k = k + 1
  13.     Next
  14.     [f8].Resize(d.Count, UBound(arr)) = brr
  15. End Sub

复制代码

TA的精华主题

TA的得分主题

发表于 2019-1-22 13:38 | 显示全部楼层
'好玩而已,不用字典来个,,,

Option Explicit

Sub test()
  Dim arr, i, j, m, n, p, t
  arr = [b3].CurrentRegion.Offset(1)
  ReDim brr(1 To UBound(arr, 1), 1 To 100) As String
  For i = 1 To UBound(arr, 1) - 2
    For j = i + 1 To UBound(arr, 1) - 1
      If arr(i, 1) > arr(j, 1) Then
        t = arr(i, 1): arr(i, 1) = arr(j, 1): arr(j, 1) = t
        t = arr(i, 2): arr(i, 2) = arr(j, 2): arr(j, 2) = t
      End If
  Next j, i
  m = 1: n = 1: p = 1
  For i = 1 To UBound(arr, 1) - 1
    m = m + 1: brr(m, n) = arr(i, 2)
    If arr(i, 1) <> arr(i + 1, 1) Then
      brr(1, n) = arr(p, 1): m = 1: n = n + 1: p = i + 1
    End If
  Next
  [f1].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
End Sub

TA的精华主题

TA的得分主题

发表于 2019-1-22 13:44 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2019-1-23 16:44 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-1-24 00:47 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
谢谢大家的帮助,很受启发。大家都很厉害,有种华山论剑的感觉,赞!
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 17:29 , Processed in 0.056605 second(s), 11 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表