提取所有唯一姓名，不重复姓名和重复姓名唯一程序

吴中泉

写这段程序时，总是觉得这三种意思有点绕，网上也有表述引起歧义，再说一下，提取所有唯一姓名、不重复姓名和重复姓名唯一。还是看图说话吧。


欢迎讨论交流。



三种提取多个没重复和重复姓名的唯一.rar (27.07 KB, 下载次数: 64)

2023-4-8 15:22 上传

点击文件名下载附件

qlmgu

感谢分享创造成果，很实用。确实解释了3种相似而又不同的概念。很实用。收藏了。

吴中泉

qlmgu 发表于 2023-4-8 15:35
感谢分享创造成果，很实用。确实解释了3种相似而又不同的概念。很实用。收藏了。

谢谢鼓励，我是刚接触VBA，类似概念还在学习思考，不断上机编辑调试，一段低效代码，发帖还希望大家指点，以例提高。

准提部林

一個字典, 做三個分歧判斷即可

shiruiqiang

学习了，一个字典解决了

吴中泉

准提部林 发表于 2023-4-8 15:58
一個字典, 做三個分歧判斷即可

谢谢大侠，你的是繁体字也

吴中泉

shiruiqiang 发表于 2023-4-8 16:01
学习了，一个字典解决了

简洁干脆利索，字典这种数据结构就是好！学习了。
由于刚接触VBA，还没有用上牛刀。正在练习VBA基本的语句、对象属性和方法，尝试实现一些功能，理解一些基本逻辑，使用一点简单算法。

lushang2018

1. Sub 测试()  ''答题专用套路--by:学习使我快乐
   
2.     Dim i, j, k, arr, crr
   
3.     Dim dic As Object, key As String, keys, items
   
4.     Set dic = CreateObject("scripting.dictionary")
   
5.     arr = Sheet1.Range("C4:C" & Sheet1.Cells(Rows.Count, "C").End(xlUp).Row)
   
6.     For i = LBound(arr) To UBound(arr)
   
7.         key = arr(i, 1)
   
8.         dic(key) = dic(key) + 1
   
9.     Next
   
10.     keys = dic.keys
    
11.     items = dic.items
    
12.     ReDim crr(1 To dic.Count, 1 To 3)
    
13.     For i = LBound(keys) To UBound(keys)
    
14.         crr(i + 1, 1) = keys(i)
    
15.         If items(i) > 1 Then
    
16.             k = k + 1
    
17.             crr(k, 3) = keys(i)
    
18.         Else
    
19.             j = j + 1
    
20.             crr(j, 2) = keys(i)
    
21.         End If
    
22.     Next
    
23.     Sheet1.Range("P4").Resize(dic.Count, 3) = crr
    
24. End Sub

复制代码

lushang2018

吴中泉

lushang2018 发表于 2023-4-8 20:06

真得很清楚，代码很新颖。就是不能复制粘贴了