用VBA实现数据筛选

刘三

各位老师：从sheet1中提取E列日期数据，有多少个不同的日期生成多少个工作表，然后把改日期内C列和D列数据填充到对应工作表中，VBA怎么实现

A刘志勇

.......................................

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.1.9
   
2.     Dim d, i%, arr, sh As Worksheet, sht As Worksheet, k, kk
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     Dim tm: tm = Timer
   
7.     Set sh = ThisWorkbook.Sheets("模板")
   
8.     For Each sht In Sheets
   
9.         If sht.Name <> "总表" And sht.Name <> sh.Name Then
   
10.             sht.Delete
    
11.         End If
    
12.     Next
    
13.     arr = Sheets("总表").UsedRange
    
14.     For i = 1 To UBound(arr)
    
15.         s = Format(Split(CDate(arr(i, 5)))(0), "yyyy-m-d")
    
16.         If Not d.Exists(s) Then
    
17.             Set d(s) = CreateObject("scripting.dictionary")
    
18.         End If
    
19.         d(s)(i) = i
    
20.     Next i
    
21.     For Each k In d.keys
    
22.         Sheets("模板").Copy after:=Sheets(Sheets.Count)
    
23.         Set sht = Sheets(Sheets.Count)
    
24.         m = 0
    
25.         ReDim brr(1 To d(k).Count, 1 To 3)
    
26.         With sht
    
27.             .Name = k
    
28.             rq = "日期： " & Format(CDate(k), "yyyy年m月d日")
    
29.             For Each kk In d(k).keys
    
30.                 m = m + 1
    
31.                 brr(m, 1) = m
    
32.                 brr(m, 2) = CStr(arr(kk, 3))
    
33.                 brr(m, 3) = arr(kk, 4)
    
34.             Next
    
35.             .Columns(2).NumberFormatLocal = "@"
    
36.             .[a9].Resize(m, 3) = brr
    
37.             .[c40] = m & " 辆"
    
38.             .[l41] = rq: .[l43] = rq
    
39.         End With
    
40.     Next k
    
41.     Sheets("总表").Activate
    
42.     Set d = Nothing
    
43.     Application.DisplayAlerts = True
    
44.     Application.ScreenUpdating = True
    
45.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
46. End Sub
    

复制代码

ykcbf1100

附件供参考。。。

gwjkkkkk

参与一下。。。

yynrzwh

附件1.rar (66.89 KB, 下载次数: 8)

2024-1-9 22:11 上传

点击文件名下载附件