ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

   
高效办公必会的Office实战技巧 永久免费,网表让Excel秒变数据库 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel函数公式学习大典 第2届Power BI可视化大赛,拿超级大奖! 免费下载Excel行业应用视频
300集Office 2010微视频教程 Tableau-数据可视化工具 打造核心竞争力的职场宝典 13门Excel免费公开课任你学
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 免费的Excel考勤计算系统
查看: 261|回复: 12

[求助] 自动分类汇总功能开发

[复制链接]

TA的精华主题

TA的得分主题

发表于 2018-7-12 11:46 来自手机 | 显示全部楼层 |阅读模式
各位大神:
我需要实现一个自动分类汇总的功能,具体见附件图片,自己怎么想都想不出来,各位能帮忙实现下吗?函数或者VBA均可以,感恩。
-36919cbd3035a068.png

TA的精华主题

TA的得分主题

发表于 2018-7-12 11:48 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-7-12 11:49 来自手机 | 显示全部楼层
chaohuahch 发表于 2018-7-12 11:48
可以用字典来解决

不是很明白,请问如何解决,谢谢

TA的精华主题

TA的得分主题

发表于 2018-7-12 12:07 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2018-7-12 12:23 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2018-7-12 12:41 | 显示全部楼层
'原始表格为当前工作表A1开始,如左图

'输出当前工作表D2开始

Option Explicit

Sub test()
  Dim dic(1), i, arr, t, m, key
  For i = 0 To UBound(dic)
    Set dic(i) = CreateObject("scripting.dictionary")
  Next
  arr = [a1].CurrentRegion
  For i = 2 To UBound(arr, 1)
    If Not dic(0).exists(arr(i, 1)) Then
      m = m + 1: dic(0)(arr(i, 1)) = m
    End If
    If dic(1).exists(arr(i, 2)) Then
      t = dic(1)(arr(i, 2))
      ReDim Preserve t(UBound(t) + 1)
      t(UBound(t)) = dic(0)(arr(i, 1))
      dic(1)(arr(i, 2)) = t
    Else
      dic(1)(arr(i, 2)) = Array(dic(0)(arr(i, 1)))
    End If
  Next
  ReDim arr(1 To dic(0).Count + 1, 1 To dic(1).Count + 1): m = 1
  For Each key In dic(0).keys: m = m + 1: arr(m, 1) = key: Next
  m = 1
  For Each key In dic(1).keys
    m = m + 1: t = dic(1)(key)
    arr(1, m) = key
    For i = 0 To UBound(t): arr(t(i) + 1, m) = "flag": Next
  Next
  With Range("d2")
    .Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    .Offset(1, 1).Resize(UBound(arr, 1) - 1, UBound(arr, 2) - 1). _
      Interior.ColorIndex = xlNone
    For Each key In .Offset(1, 1).Resize(UBound(arr, 1) - 1, UBound(arr, 2) - 1)
      If key = "flag" Then key.Interior.Color = vbRed: key.ClearContents
    Next
  End With
End Sub

TA的精华主题

TA的得分主题

发表于 2018-7-12 12:52 | 显示全部楼层
  1. Sub test()
  2.   Dim r%, i%
  3.   Dim arr, brr
  4.   Dim d As Object
  5.   Set dh = CreateObject("scripting.dictionary")
  6.   Set dv = CreateObject("scripting.dictionary")
  7.   With Worksheets("sheet1")
  8.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
  9.     arr = .Range("a2:b" & r)
  10.     j = 1
  11.     For i = 1 To UBound(arr)
  12.       If Not dh.exists(arr(i, 2)) Then
  13.         j = j + 1
  14.         dh(arr(i, 2)) = j
  15.       End If
  16.     Next
  17.     For i = 1 To UBound(arr)
  18.       If Not dv.exists(arr(i, 1)) Then
  19.         ReDim brr(1 To j)
  20.         brr(1) = arr(i, 1)
  21.       Else
  22.         brr = dv(arr(i, 1))
  23.       End If
  24.       n = dh(arr(i, 2))
  25.       brr(n) = brr(n) + 1
  26.       dv(arr(i, 1)) = brr
  27.     Next
  28.     .Range("h1").Resize(.Rows.Count, .Columns.Count - 7).Clear
  29.     .Range("h1").Resize(.Rows.Count, .Columns.Count - 7).Interior.ColorIndex = xlNone
  30.     .Range("h1") = "物料代码"
  31.     .Range("i1").Resize(1, dh.Count) = dh.keys
  32.     .Range("h2").Resize(dv.Count, UBound(brr)) = Application.Transpose(Application.Transpose(dv.items))
  33.     r = .Cells(.Rows.Count, 8).End(xlUp).Row
  34.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
  35.     For i = 2 To r
  36.       For j = 9 To c
  37.         If .Cells(i, j) <> "" Then
  38.           .Cells(i, j) = ""
  39.           .Cells(i, j).Interior.ColorIndex = 3
  40.         End If
  41.       Next
  42.     Next
  43.   End With
  44. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2018-7-12 12:53 | 显示全部楼层
借5楼老师的附件练练手。

工作簿1.rar

25.72 KB, 下载次数: 27

TA的精华主题

TA的得分主题

发表于 2018-7-12 13:04 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-7-12 13:31 来自手机 | 显示全部楼层
opiona 发表于 2018-7-12 12:23

谢谢老师,问题已经解决。老师,如果我要把结果放到另外一张表格上面,应该如何操作?
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,高效办公专列,每天发车

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

GMT+8, 2018-9-25 09:50 , Processed in 0.080708 second(s), 14 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 2001-2017 Wooffice Inc.

   

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

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

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