VBA字典提取

chj6533

用字典做了个不重复的提取，用了两次循环，第1次，先按姓名去重复；第二次 再以单位为条件提取，，效果达到了。


但突发奇想。。。可不可以一次循环就解决问题，请论坛有兴趣的老师解一下。

xiangbaoan

1. Sub 提取1次循环() ' 测试
   
2.   Dim ar, Dict As Object
   
3.   Dim i As Long, j As Integer, k As Long
   
4.   Set Dict = CreateObject("Scripting.Dictionary")
   
5.   ar = Range("A1").CurrentRegion.Resize(, 3).Offset(1).Value
   
6.   For i = 1 To UBound(ar) - 1
   
7.     If Not Dict.Exists(ar(i, 2)) Then
   
8.       If ar(i, 1) = "DW3" Then
   
9.         k = k + 1
   
10.         For j = 1 To UBound(ar, 2)
    
11.           ar(k, j) = ar(i, j)
    
12.         Next
    
13.       End If
    
14.       Dict.Add ar(i, 2), ""
    
15.     End If
    
16.   Next
    
17.   Range("H6").Resize(k, UBound(ar, 2)) = ar
    
18.   Set Dict = Nothing
    
19. End Sub

复制代码

盼盼198310

单位&姓名 作字典的key 试试

Hontyu

我怎么感觉被楼主写的代码带偏了，你指的效果达到了，到底是什么效果

chj6533

Hontyu 发表于 2022-9-18 14:31
我怎么感觉被楼主写的代码带偏了，你指的效果达到了，到底是什么效果

就是 姓名中的字段 可能会在两个地方出现 ，保留第一出现的所属单位为准。比如：此例姓名为WM1的出现在了DW1和DW3的单位中，，，但只算在单位是DW1。统计DW3的人数时，这个人不算的。不知我说清楚了没？

清风竹-

请看附件。

chj6533

清风竹- 发表于 2022-9-18 15:40
请看附件。

效果是达到了。感谢    ！ 不过还是多用了个 小循环，，不知在数据量很大的情况下  我的和你的速度谁快。。后面有时间我自己测试一下。

清风竹-

chj6533 发表于 2022-9-18 16:02
效果是达到了。感谢    ！ 不过还是多用了个 小循环，，不知在数据量很大的情况下  我的和你的速度谁快。 ...

Sub 提取1次循环()
Dim d, d2, arr1, n, i, j, x
Set d = CreateObject("scripting.Dictionary")
Set d2 = CreateObject("scripting.Dictionary")
n = Range("b" & Rows.Count).End(3).Row
arr1 = [a2].Resize(n - 1, 3)
    For i = 1 To UBound(arr1)
        If Not d.Exists(arr1(i, 2)) Then
           d.Add arr1(i, 2), ""
            If arr1(i, 1) = "DW3" Then
               d2.Add arr1(i, 2), Array(arr1(i, 1), arr1(i, 2), arr1(i, 3))
            End If
       End If
    Next
[h2].Resize(d2.Count, 3) = WorksheetFunction.Transpose(WorksheetFunction.Transpose(d2.items))

End Sub

ygwyj

1. Sub 提取1次循环()
   
2. Dim arr, d1, d2, i, n, m
   
3. On Error Resume Next
   
4. Set d1 = CreateObject("scripting.Dictionary")
   
5. Set d2 = CreateObject("scripting.Dictionary")
   
6. arr = Range("a1").CurrentRegion
   
7. For i = 2 To UBound(arr)
   
8.     If Not d1.exists(arr(i, 2)) Then
   
9.         d1(arr(i, 2)) = ""
   
10.         If arr(i, 1) = "DW3" Then
    
11.             d2.Add arr(i, 2), Array(arr(i, 1), arr(i, 2), arr(i, 3))
    
12.         End If
    
13.     End If
    
14. Next
    
15. [h2].Resize(d2.Count, 3) = WorksheetFunction.Transpose(WorksheetFunction.Transpose(d2.items))
    
16. End Sub

复制代码

ygwyj

字典提取问题.rar (14 KB, 下载次数: 7)

2022-9-18 16:25 上传

点击文件名下载附件

测一下我这个试试，我没测，感觉应快点