请大神帮助，完成后红包奉上

NONO2020

请帮助，见附件，谢谢！ 求教.zip (11.74 KB, 下载次数: 49)

2019-9-6 05:36 上传

点击文件名下载附件

约定的童话

你这不留个联系方式啊？

opel-wong

看了一下，难度不大，有空写下，

蓝桥玄霜

筛选

1. Sub lqxs()
   
2. Dim Arr, i&, x$, y, kk, tt, aa, j%, sl, hs$
   
3. Dim d, k, t
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Application.ScreenUpdating = False
   
6. Sheet2.Activate
   
7. [a2:r5000].ClearContents
   
8. Arr = Sheet1.[a1].CurrentRegion
   
9. For i = 2 To UBound(Arr)
   
10.     y = Arr(i, 1)
    
11.     If Arr(i, 14) <> "" Then x = Arr(i, 14)
    
12.         
    
13.     If d.exists(x) = False Then Set d(x) = CreateObject("Scripting.Dictionary")
    
14.     d(x)(y) = d(x)(y) & i & ","
    
15. Next
    
16. k = d.keys: t = d.items
    
17. For i = 0 To UBound(k)
    
18.     kk = t(i).keys: tt = t(i).items
    
19.     For ii = 0 To UBound(kk)
    
20.         tt(ii) = Left(tt(ii), Len(tt(ii)) - 1)
    
21.         sl = 0
    
22.         If InStr(tt(ii), ",") Then
    
23.             aa = Split(tt(ii), ",")
    
24.             For j = 0 To UBound(aa)
    
25.                 sl = sl + Arr(aa(j), 4)
    
26.             Next
    
27.         Else
    
28.             sl = Arr(tt(ii), 4)
    
29.         End If
    
30.         If sl <= 4 Then
    
31.             hs = hs & tt(ii) & ","
    
32.         End If
    
33.     Next
    
34. Next
    
35. hs = Left(hs, Len(hs) - 1)
    
36. aa = Split(hs, ",")
    
37. For j = 0 To UBound(aa)
    
38.     Cells(j + 2, 1).Resize(1, UBound(Arr, 2)) = Application.Index(Arr, aa(j), 0)
    
39. Next
    
40. Application.ScreenUpdating = True
    
41. End Sub
    

复制代码

的代码：

qx-liuwx

怀念以前的EH

NONO2020

V:    RVR6868

zpy2

NONO2020 发表于 2019-9-6 09:28
V:    RVR6868

完成了，这是发红包的节奏吗，

qx-liuwx

都给出Q、非要人加你V
哈哈

NONO2020

请教，这个代码怎么录入？开发工具？

deadzlq

PQ参考解法