如何用VBA提取多个数据去重

yynrzwh

数据提取.zip (568.46 KB, 下载次数: 11)

2024-5-27 10:40 上传

点击文件名下载附件

grf1973

。。。。。。。。。。。。。。

grf1973

LIUZHU 发表于 2024-5-27 10:12
JSA代码

似乎没考虑同一天只计数一次的要求。

LIUZHU

grf1973 发表于 2024-5-27 11:14
似乎没考虑同一天只计数一次的要求。

考虑了，只是这条写错了

LIUZHU

5550381 发表于 2024-5-27 10:38
如果旁边在做一列对比当月未出现客户要怎么写呢，能分今年和去年当月分别没出现的客户名称

那就是增加一个字典来判断

ykcbf1100

5550381 发表于 2024-5-27 10:13
以单元格中月份的为提取基础的话，提取出来的数据还会有空值。其他月份的日期会出现数据集合到一起没办法 ...

空值的话，加个判断就行了。

林木水

1. Option Explicit
   
2. 
   
3. Sub 数据提取()
   
4. Dim arr, brr, crr, d0 As New Dictionary, d1 As New Dictionary, d2 As New Dictionary, sh1 As Worksheet, sh2 As Worksheet, h As Long, i As Long, m As String
   
5.     Set sh1 = ThisWorkbook.Worksheets("今年")
   
6.     Set sh2 = ThisWorkbook.Worksheets("前年")
   
7.     With sh1    '今年表格内容存入数组
   
8.         .AutoFilterMode = False
   
9.         h = .Cells(.Rows.Count, "A").End(xlUp).Row
   
10.         arr = .Range("A3:I" & h)
    
11.     End With
    
12.     With sh2    '前年表格内容存入数组
    
13.         .AutoFilterMode = False
    
14.         h = .Cells(.Rows.Count, "A").End(xlUp).Row
    
15.         brr = .Range("A3:I" & h)
    
16.     End With
    
17.     m = Sheet1.Range("C2").Value
    
18.     For i = 1 To UBound(arr)   '今年数据提取
    
19.         If Month(VBA.CVDate(arr(i, 2))) & "月份" = m Then
    
20.             sh1.Cells(i + 2, "J") = m
    
21.             If Not d0.Exists(arr(i, 1) & arr(i, 2)) Then
    
22.                 d1(arr(i, 1)) = d1(arr(i, 1)) + 1
    
23.                 d0(arr(i, 1) & arr(i, 2)) = ""
    
24.             End If
    
25.             d2(arr(i, 1)) = d2(arr(i, 1)) + arr(i, 8)
    
26.         End If
    
27.     Next
    
28.     With Sheet1 '写入今年数据
    
29.         .Range("B5:D65535").ClearContents   '清空历史数据
    
30.         .Range("B5").Resize(d1.Count, 1) = Application.Transpose(d1.Keys)
    
31.         .Range("C5").Resize(d1.Count, 1) = Application.Transpose(d1.Items)
    
32.         .Range("D5").Resize(d1.Count, 1) = Application.Transpose(d2.Items)
    
33.     End With
    
34.     d0.RemoveAll: d1.RemoveAll: d2.RemoveAll    '清空字典
    
35.     For i = 1 To UBound(brr)   '前年数据提取
    
36.         If Month(VBA.CVDate(brr(i, 2))) & "月份" = m Then
    
37.             sh2.Cells(i + 2, "J") = m
    
38.             If Not d0.Exists(brr(i, 1) & brr(i, 2)) Then
    
39.                 d1(brr(i, 1)) = d1(brr(i, 1)) + 1
    
40.                 d0(brr(i, 1) & brr(i, 2)) = ""
    
41.             End If
    
42.             d2(brr(i, 1)) = d2(brr(i, 1)) + brr(i, 8)
    
43.         End If
    
44.     Next
    
45.     With Sheet1 '写入前年数据
    
46.         .Range("F5:H65535").ClearContents   '清空历史数据
    
47.         .Range("F5").Resize(d1.Count, 1) = Application.Transpose(d1.Keys)
    
48.         .Range("G5").Resize(d1.Count, 1) = Application.Transpose(d1.Items)
    
49.         .Range("H5").Resize(d1.Count, 1) = Application.Transpose(d2.Items)
    
50.     End With
    
51.     With Sheet1 '添加线框+字体居左
    
52.         h = .Cells(.Rows.Count, "B").End(xlUp).Row
    
53.         .Range("B5:D65535").Borders.LineStyle = xlNone
    
54.         .Range("B5:D" & h).Borders.LineStyle = 1
    
55.         .Range("B5:D" & h).HorizontalAlignment = xlLeft
    
56.         h = .Cells(.Rows.Count, "F").End(xlUp).Row
    
57.         .Range("F5:H65535").Borders.LineStyle = xlNone
    
58.         .Range("F5:H" & h).Borders.LineStyle = 1
    
59.         Range("F5:H" & h).HorizontalAlignment = xlLeft
    
60.     End With
    
61. End Sub

复制代码

sunya_0529

WPS里的JSA练习一下，写成自定义函数——