VBA实现数据透视表

qiujianxin

附件中的sheet1，想用VBA的方式做成sheet2的格式，
其实就是sheet1中用数据透视表对上架日+作业人名称+发出方+订单号，对 这七列汇总，汇总结束后将作业人名称列移到最后一列，并根据“匹配”表中的信息在后面加上相应的代号。sheet1的行数要做成动态的，不能固定多少行，因为每次都不一样
前面的表“R”和表“S”是表sheet1中的W列“DEPT”做的筛选项（数据透视表中筛选项功能）
因为这个文件每天都要用到，每天都用数据透视也比较繁琐，是不是有大神可以用VBA能实现此功能，谢谢了！

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Set d1 = CreateObject("scripting.dictionary")
   
7.     '    Set reg = CreateObject("vbscript.regexp")
   
8.     With Worksheets("匹配")
   
9.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
10.         arr = .Range("a2:b" & r)
    
11.         For i = 1 To UBound(arr)
    
12.             d1(arr(i, 1)) = arr(i, 2)
    
13.         Next
    
14.     End With
    
15.     With Worksheets("sheet1")
    
16.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
17.         c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
18.         arr = .Range("a2").Resize(r - 1, c)
    
19.         For i = 1 To UBound(arr)
    
20.             If IsNumeric(arr(i, 1)) Then
    
21.                 xm = arr(i, 2) & "+" & arr(i, 30) & "+" & arr(i, 3) & "+" & arr(i, 4)
    
22.                 If Not d.exists(xm) Then
    
23.                     ReDim brr(1 To 12)
    
24.                     brr(1) = arr(i, 2)
    
25.                     brr(2) = arr(i, 3)
    
26.                     brr(3) = arr(i, 4)
    
27.                     brr(11) = arr(i, 30)
    
28.                     If d1.exists(brr(11)) Then
    
29.                         brr(12) = d1(brr(11))
    
30.                     End If
    
31.                 Else
    
32.                     brr = d(xm)
    
33.                 End If
    
34.                 For j = 4 To 10
    
35.                     brr(j) = brr(j) + Val(arr(i, 10 + j))
    
36.                 Next
    
37.                 d(xm) = brr
    
38.             End If
    
39.         Next
    
40.     End With
    
41.     ReDim crr(1 To d.Count, 1 To 12)
    
42.     m = 0
    
43.     ReDim drr(1 To 12)
    
44.     drr(1) = "总计"
    
45.     For Each aa In d.keys
    
46.         brr = d(aa)
    
47.         m = m + 1
    
48.         For j = 1 To UBound(brr)
    
49.             crr(m, j) = brr(j)
    
50.         Next
    
51.         For j = 4 To 10
    
52.             drr(j) = drr(j) + brr(j)
    
53.         Next
    
54.     Next
    
55.     With Worksheets("sheet2")
    
56.         .Range("a4:l" & .Rows.Count).ClearContents
    
57.         .Range("a4").Resize(UBound(crr), UBound(crr, 2)) = crr
    
58.         .Cells(3 + UBound(crr) + 1, 1).Resize(1, UBound(drr)) = drr
    
59.         With .Range("a3").Resize(1 + UBound(crr) + 1, 12)
    
60.             .Borders.LineStyle = xlContinuous
    
61.         End With
    
62.     End With
    
63. End Sub
    

复制代码

chxw68

参与一下。

Qs18

Sub qs18()
    Dim arr, dic
    Set dic = CreateObject("scripting.dictionary")
    arr = Sheet4.Range("a1").CurrentRegion.Value
    ReDim brr(1 To UBound(arr), 1 To 12)
    For i = 2 To UBound(arr)
        s = Join(Array(arr(i, 2), arr(i, 30), arr(i, 3), arr(i, 4)))
        If Not dic.exists(s) Then
            m = m + 1
            dic(s) = m
            ss = Split(s)
            For a = 0 To 3
                brr(m, a + 1) = ss(a)
            Next
            brr(m, 5) = Val(arr(i, 14))
            brr(m, 6) = Val(arr(i, 15))
            brr(m, 7) = Val(arr(i, 16))
            brr(m, 8) = Val(arr(i, 17))
            brr(m, 9) = Val(arr(i, 18))
            brr(m, 10) = Val(arr(i, 19))
            brr(m, 11) = Val(arr(i, 20))
            brr(m, 12) = arr(i, 30)
        Else
            r = dic(s)
            brr(r, 5) = brr(r, 5) + Val(arr(i, 14))
            brr(r, 6) = brr(r, 6) + Val(arr(i, 15))
            brr(r, 7) = brr(r, 7) + Val(arr(i, 16))
            brr(r, 8) = brr(r, 8) + Val(arr(i, 17))
            brr(r, 9) = brr(r, 9) + Val(arr(i, 18))
            brr(r, 10) = brr(r, 10) + Val(arr(i, 19))
            brr(r, 11) = brr(r, 11) + Val(arr(i, 20))
        End If
    Next
    Sheet3.Range("a10").Resize(m, 12) = brr
End Sub

Qs18

试试..............

Qs18

试一下.....................

qiujianxin

chxw68 发表于 2024-6-29 18:18
参与一下。

老师你好，感谢帮忙，还有点小问题，文件中原来是没有sheet2的，需要在做数据透视的时候添加，要不然代码运行的时候会报错，sheet2中需要包含表头行，即上架日，发出方，订单号等等这些信息。
需要对sheet1中的W列“DEPT”这一列做筛选透视，分别生成表“R”和表“S”两个表，格式同sheet2 是一致的，是否可以请您再辛苦看一下，谢谢！

chxw68

修改好了。

qiujianxin

chxw68 发表于 2024-6-30 10:05
修改好了。

谢谢老师，辛苦，就是我想要的，我研究研究

qiujianxin

chxw68 发表于 2024-6-30 10:05
修改好了。

老师，如果“匹配”这个工作表我不放在这个工作簿里面，单独新建一个工作簿的话，应该怎么去匹配到ABCD这种代号呢？