跪求代码

gbscd

跪求大神能帮忙解决代码问题，需求详如附件

能不能用VBA实现：
（可以说就是数据透视功能：）


按照“日期”放在如“统计表”列的位置；
“学员姓名”、“老师姓名”“店名”放在行；
对代课节数进行汇总求和



小老弟在此跪谢了

shiruiqiang

字典嵌套一下，很简单。不用跪求

gbscd

shiruiqiang 发表于 2024-5-13 17:55
字典嵌套一下，很简单。不用跪求

我真的不会，能不能帮忙看一下
谢谢了！

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, i&, j&, r&, dic As Object, strKey$
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = Sheets(1).[A6].CurrentRegion.Value
    For i = 2 To UBound(ar)
        strKey = ""
        For j = 1 To 4
            strKey = strKey & ar(i, j)
        Next j
        dic(strKey) = dic(strKey) + ar(i, 5)
    Next i
   
    r = Cells(Rows.Count, "A").End(xlUp).Row
    ar = Range("A4:AI" & r).Value
    For i = 2 To UBound(ar)
        strKey = ""
        For j = 1 To 3
            strKey = strKey & ar(i, j)
        Next j
        For j = 4 To UBound(ar, 2)
            ar(i, j) = dic(ar(1, j) & strKey)
        Next j
    Next i
   
    [A4].Resize(UBound(ar), UBound(ar, 2)) = ar
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考。。。

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.5.13
   
2.     Dim arr, brr, d, s
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     ReDim brr(1 To 100000, 1 To 100)
   
7.     m = 1: n = 3
   
8.     On Error Resume Next
   
9.     With Sheets("数据")
   
10.         r = .Cells(Rows.Count, 1).End(3).Row
    
11.         arr = .[a1].Resize(r, 5)
    
12.         brr(1, 1) = arr(6, 2)
    
13.         brr(1, 2) = arr(6, 3)
    
14.         brr(1, 3) = arr(6, 4)
    
15.     End With
    
16.     For i = 7 To UBound(arr)
    
17.         If arr(i, 1) <> Empty Then
    
18.             s = arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4)
    
19.             If Not d.exists(s) Then
    
20.                 m = m + 1
    
21.                 d(s) = m
    
22.                 brr(m, 1) = arr(i, 2)
    
23.                 brr(m, 2) = arr(i, 3)
    
24.                 brr(m, 3) = arr(i, 4)
    
25.             End If
    
26.             r = d(arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4))
    
27.             s = Format(arr(i, 1), "yyyy-mm")
    
28.             If Not d.exists(s) Then
    
29.                 n = n + 1
    
30.                 d(s) = n
    
31.                 brr(1, n) = s
    
32.             End If
    
33.             c = d(Format(arr(i, 1), "yyyy-mm"))
    
34.             brr(r, c) = brr(r, c) + arr(i, 5)
    
35.         End If
    
36.     Next
    
37.     With Sheets("统计")
    
38.         .UsedRange.Clear
    
39.         .[a1].Resize(m, n) = brr
    
40.         .[a1].Resize(1, n).Interior.Color = 49407
    
41.         .[a2].Resize(m - 1, 1).Interior.Color = 5296274
    
42.         ActiveWindow.DisplayZeros = False
    
43.         Set Rng = .[a1].Resize(m, n)
    
44.         With Rng
    
45.             .Borders.LineStyle = 1
    
46.             .HorizontalAlignment = xlCenter
    
47.             .VerticalAlignment = xlCenter
    
48.             With .Font
    
49.                 .Name = "微软雅黑"
    
50.                 .Size = 11
    
51.             End With
    
52.         End With
    
53.         .[a2].Resize(m - 1, n).Sort .[a2], 1
    
54.     End With
    
55.     Set d = Nothing
    
56.     Application.ScreenUpdating = True
    
57.     MsgBox "OK！"
    
58. End Sub
    
59. 
    

复制代码

shiruiqiang

gbscd 发表于 2024-5-13 17:55
我真的不会，能不能帮忙看一下
谢谢了！

====================

cnmlgb9998

PQ 一步到位，还要什么VBA？？？？？

gbscd

shiruiqiang 发表于 2024-5-13 19:12
====================

@shiruiqiang,非常感谢shiruiqiang老师的相助，真的非常感谢！！！！