[抛砖引玉]根据账号查找接点人，依次类推

微风～雨

[抛砖引玉额]恕我愚笨，最近处理了一单查找数据题，足足困扰了我三个小时，因之前未接触过此类
题目，思索近一个半小时方有思路，随后又在代码上测试一小时有余，方才解决此题，故想和论坛
坛友讨论，是否有另外可行方法，鄙人方法略显简陋，请见谅。
要求：1、根据会员账号在接点人列找到2个会员名，这2个会员名的会员账号又找到2个接点人，以此类退
    示例、1.首先找到第489行卢志爱的会员账号。
        2.查找卢志爱的会员账号，找到了刘维和谭银华
        3.再分别查找刘维和谭银华的账号
         ……以此类推
        5、就是每个会员账号都能查到两个接点人，这样排列下来（实际部分只能找到一个接点人）自从接触vba，在论坛遨游中学习了很多前辈经验，故也想献丑一番自己所学。
原文本不包含代码，代码在另外附件中。

丸子不是小孩子

另一方法，代码应该更加简洁，结果排序不一样，但内容是一样的。。。。//更新一下附件，有一个变量赋值是多余的

微风～雨

丸子不是小孩子 发表于 2022-3-8 20:38
另一方法，代码应该更加简洁，结果排序不一样，但内容是一样的。。。。//更新一下附件，有一个变量赋值是多 ...

好，感谢参与，自从加入论坛确实学到了不少，这次刚好交谈一下大家的代码，思路想到挺快的，代码可行性修改了一个多小时

ericxzhou

1. Sub test()
   
2.     Dim i%, j%, Cn, sql$, arr
   
3.     Set Cn = CreateObject("ADODB.Connection")
   
4.     Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
   
5.     sql = "SELECT DISTINCT 账号 FROM [数据$]"
   
6.     arr = Cn.Execute(sql).getrows
   
7.     With Sheet2
   
8.         [a1].CurrentRegion.Offset(1).ClearContents
   
9.         For i = 0 To UBound(arr, 2)
   
10.             j = .[a65536].End(3).Row + 1
    
11.             sql = "SELECT * FROM [数据$] WHERE 账号='" & arr(0, i) & "' OR 接点人='" & arr(0, i) & "'"
    
12.             .Cells(j, 1).CopyFromRecordset Cn.Execute(sql)
    
13.         Next
    
14.     End With
    
15. End Sub

复制代码

jiangxiaoyun

按理解。1，将接点人放进字典，并对账号进行不重复计数，等于2（大于2不知道算不算）才要，小于2的不要。2，然后对比账号，做个判断是否存在字典中？这样？

blackttea1

看下，学习下

游乐缘

感谢分享，留名学习