Excel数据分类汇总（VBA）

palehe

求助，我有几分源数据，要根据这些源数据中的识别码/科别 分别拆分到对应 识别码/科别 的sheet页签中保存，跪求vab实现方式，谢谢~
图例：


效果：
将源数据1 源数据2（后面可能会有源数据3……）的数据根据科别对应到sheet页签中~！
附件：
数据分类保存模拟.7z (9.97 KB, 下载次数: 23)

2019-6-17 14:53 上传

点击文件名下载附件

dsmch

1. Sub dsmch()
   
2. Set d = CreateObject("scripting.dictionary")
   
3. For Each sht In Sheets
   
4.     If sht.Name Like "源数据*" Then
   
5.         arr = sht.Range("a1").CurrentRegion
   
6.         For i = 2 To UBound(arr)
   
7.             d(arr(i, 6)) = d(arr(i, 6)) + 1
   
8.             sht.Cells(i, 1).Resize(1, UBound(arr, 2)).Copy Sheets("" & arr(i, 6)).Cells(d(arr(i, 6)) + 1, 1)
   
9.         Next
   
10.     End If
    
11. Next
    
12. End Sub

复制代码

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j, k, sum, t, dic, m
  Set dic = CreateObject("scripting.dictionary")
  t = Split("源数据1 源数据2")
  For i = 0 To UBound(t)
    arr = Sheets(t(i)).[a1].CurrentRegion
    If i = 0 Then ReDim brr(1 To 20, 1 To 10 ^ 3, 1 To UBound(arr, 2)), sum(1 To 20)
    For j = 2 To UBound(arr, 1)
      If Not dic.exists(arr(j, 6)) Then m = m + 1: dic(arr(j, 6)) = m
      sum(dic(arr(j, 6))) = sum(dic(arr(j, 6))) + 1
      For k = 1 To UBound(arr, 2)
        brr(dic(arr(j, 6)), sum(dic(arr(j, 6))), k) = arr(j, k)
  Next k, j, i
  i = 0
  For Each t In dic.keys
    m = 0: i = i + 1
    ReDim arr(1 To 10 ^ 3, 1 To UBound(arr, 2))
    For j = 1 To sum(i)
      m = m + 1
      For k = 1 To UBound(brr, 3): arr(m, k) = brr(i, j, k): Next
    Next
    With Sheets(t).[a2]
      .Resize(Rows.Count - 1, UBound(arr, 2)).ClearContents
      If m > 0 Then .Resize(m, UBound(arr, 2)) = arr
    End With
  Next
End Sub

Yalishanda30

附件供参考

wdx223

1. Sub test()
   
2. Dim data, i&, j&, wkt, header, dic, temp, d, sht
   
3. Set dic = CreateObject("Scripting.Dictionary")
   
4. Set sht = CreateObject("Scripting.Dictionary")
   
5. For Each wkt In ThisWorkbook.Worksheets
   
6.     sht(wkt.Name) = ""
   
7.     If InStr(wkt.Name, "源数据") > 0 Then
   
8.         With wkt
   
9.             header = .UsedRange.Rows(1).Value
   
10.             data = .UsedRange.Value
    
11.             For i = 2 To UBound(data)
    
12.                 If data(i, 1) <> "" Then
    
13.                     If Not dic.exists(data(i, 6)) Then
    
14.                         ReDim temp(1 To 6, 1 To 1)
    
15.                         For j = 1 To 6
    
16.                             temp(j, 1) = data(i, j)
    
17.                         Next j
    
18.                         dic(data(i, 6)) = temp
    
19.                     Else
    
20.                         temp = dic(data(i, 6))
    
21.                         ReDim Preserve temp(1 To 6, 1 To UBound(temp, 2) + 1)
    
22.                         For j = 1 To 6
    
23.                             temp(j, UBound(temp, 2)) = data(i, j)
    
24.                         Next j
    
25.                         dic(data(i, 6)) = temp
    
26.                     End If
    
27.                 End If
    
28.                 temp = ""
    
29.             Next i
    
30.             data = ""
    
31.         End With
    
32.     End If
    
33. Next wkt
    
34. 
    
35. For Each d In dic.keys
    
36.     If sht.exists(d) Then
    
37.         With ThisWorkbook.Worksheets(d)
    
38.             .Cells.Clear
    
39.             .[A1].Resize(1, UBound(header, 2)) = header
    
40.             .[A2].Resize(UBound(dic(d), 2), 6) = Application.Transpose(dic(d))
    
41.         End With
    
42.     End If
    
43. Next d
    
44.                               
    
45. End Sub

复制代码

palehe

dsmch 发表于 2019-6-17 15:20

如果我要匹配的数据信息再第28列，即AB列的名字与下面的分页签名字一致
要复制过去的列宽也是28列，代码应该怎么修改呢？
而且我的的源数据 sheet页签名字不一定要叫源数据，因为是从系统里面导出来的
麻烦大神再看一下呢？
之前模拟那份数据是没有问题了~！自己琢磨了半天还是没有改成功

palehe

一把小刀闯天下 发表于 2019-6-17 15:25
Option Explicit

Sub test()

谢谢，此前的模拟数据能实现了
但是我实际运用的数据会比较大，所以 最终参考的列是在第28列，即AB列
而且我源数据是从系统里面导出来的，所以名字不一定是源数据，有可能是时间戳，
麻烦看看代码是否能修改一下来实现呢？

palehe

wdx223 发表于 2019-6-17 15:45

谢谢，之前的模拟数据能够达到要求，
然后我实际的数据是有28列，即在AB列
而且我的源数据页签名字是根据系统导出的时候时间戳来确定的
自己捣腾了半天也没有改正确代码，麻烦看看能修改一下实现么？
谢谢了~！

一把小刀闯天下

全军覆没，无一幸免。楼主很强大，，，