自动分类汇总功能开发

Eyu_Elvis

各位大神:
我需要实现一个自动分类汇总的功能，具体见附件图片，自己怎么想都想不出来，各位能帮忙实现下吗？函数或者VBA均可以，感恩。

chaohuahch

可以用字典来解决

Eyu_Elvis

chaohuahch 发表于 2018-7-12 11:48
可以用字典来解决

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

gdw831001

透视表不行吗
   

opiona

QQ14885553.rar (23.26 KB, 下载次数: 35)

2018-7-12 12:22 上传

点击文件名下载附件

一把小刀闯天下

'原始表格为当前工作表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

chxw68

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
    

复制代码

chxw68

借5楼老师的附件练练手。

lenghonghai601

1. transform pivot学习了。

复制代码

Eyu_Elvis

opiona 发表于 2018-7-12 12:23

谢谢老师，问题已经解决。老师，如果我要把结果放到另外一张表格上面，应该如何操作？