怎么从每月数据筛选汇总

ykcbf1100

joy.008@163.com 发表于 2024-9-3 16:26
这个比较高深 我是直接安装 KMSpico 破解 没玩过注册表

不是注册表，是个软件。

wang-way

1. Public Sub VX_wang_way()
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim wb As Workbook, sht As Worksheet
   
5.     Dim oWb As Workbook, oSht As Worksheet
   
6.     Dim d As Object
   
7.     Dim ar(1 To 10000, 1 To 18)
   
8.     Set d = CreateObject("Scripting.Dictionary")
   
9.     Dim fp, fps
   
10.     Set wb = Application.ThisWorkbook
    
11.     Set sht = wb.Worksheets(1)
    
12.     fd = wb.Path & ""
    
13.     Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(fd).Files
    
14.     For Each f In fs
    
15.         fn = f.Name
    
16.         fp = f.Path
    
17.         If fp Like "*保教退费.xlsx" Then
    
18.             Debug.Print fp
    
19.             Set oWb = Workbooks.Open(fp)
    
20.             '从文件名分割月份数字
    
21.             mon = Split(oWb.Name, "月")(0)
    
22.             '月份列
    
23.             c = mon + 3
    
24.             For Each oSht In oWb.Worksheets
    
25.                 With oSht
    
26.                     erow = .Cells(.Rows.Count, 1).End(xlUp).Row
    
27.                     For i = 4 To erow
    
28.                         Key = .Cells(i, 2).Value
    
29.                         If Val(Key) <> 0 And Val(.Cells(i, 3).Value) <> 0 Then
    
30.                             If d.exists(Key) = False Then
    
31.                                 r = d.Count + 1
    
32.                                 d(Key) = r
    
33.                                 ar(r, 1) = r '序号
    
34.                                 ar(r, 2) = .Name '班级
    
35.                                 ar(r, 3) = Key '姓名
    
36.                                 ar(r, c) = .Cells(i, 3).Value
    
37.                                 ar(r, 16) = ar(r, 16) + .Cells(i, 3).Value
    
38.                             Else
    
39.                                 r = d(Key)
    
40.                                 ar(r, c) = .Cells(i, 4).Value
    
41.                                 ar(r, 16) = ar(r, 16) + .Cells(i, 3).Value
    
42.                             End If
    
43.                         End If
    
44.                     Next i
    
45.                 End With
    
46.                 'Stop
    
47.             Next oSht
    
48.             oWb.Close False
    
49.         End If
    
50.     Next
    
51.     With sht
    
52.         .UsedRange.Offset(3).Clear
    
53.         .Range("a4").Resize(10000, 18).Value = ar
    
54.     End With
    
55.     Application.DisplayAlerts = True
    
56.     Application.ScreenUpdating = True
    
57. End Sub
    

复制代码