Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2057|回复: 2

[已解决]用VBA数组或字典挑选相同

[复制链接]
发表于 2017-6-21 08:42 | 显示全部楼层 |阅读模式
本帖最后由 laoau138 于 2017-6-21 15:11 编辑

用VBA数组或字典挑选相同


最佳答案
2017-6-21 14:33
  1. Sub tt()
  2.     arr = [a1].CurrentRegion
  3.     Set d = CreateObject("scripting.dictionary")
  4.     For i = 2 To UBound(arr)
  5.         x = arr(i, 3)
  6.         If Not d.exists(x) Then d(x) = i Else d(x) = d(x) & "," & i
  7.     Next
  8.     ReDim brr(1 To d.Count, 1 To 5)
  9.     For Each x In d.keys
  10.         If InStr(d(x), ",") > 0 Then
  11.             krr = Split(d(x), ",")
  12.             kmax = krr(UBound(krr)): kmin = krr(0)
  13.             If arr(kmax, 2) <> arr(kmin, 2) Then
  14.                 n = n + 1: brr(n, 2) = "'" & x
  15.                 brr(n, 1) = arr(kmax, 2): brr(n, 3) = kmax
  16.                 brr(n, 4) = arr(kmin, 2): brr(n, 5) = kmin
  17.             End If
  18.         End If
  19.     Next
  20.     [e20].Resize(n, 5) = brr
  21. End Sub
复制代码
用VBA数组或字典挑选相同.png

用VBA数组或字典挑选相同.rar

220.65 KB, 下载次数: 17

excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2017-6-21 14:33 | 显示全部楼层    本楼为最佳答案   
  1. Sub tt()
  2.     arr = [a1].CurrentRegion
  3.     Set d = CreateObject("scripting.dictionary")
  4.     For i = 2 To UBound(arr)
  5.         x = arr(i, 3)
  6.         If Not d.exists(x) Then d(x) = i Else d(x) = d(x) & "," & i
  7.     Next
  8.     ReDim brr(1 To d.Count, 1 To 5)
  9.     For Each x In d.keys
  10.         If InStr(d(x), ",") > 0 Then
  11.             krr = Split(d(x), ",")
  12.             kmax = krr(UBound(krr)): kmin = krr(0)
  13.             If arr(kmax, 2) <> arr(kmin, 2) Then
  14.                 n = n + 1: brr(n, 2) = "'" & x
  15.                 brr(n, 1) = arr(kmax, 2): brr(n, 3) = kmax
  16.                 brr(n, 4) = arr(kmin, 2): brr(n, 5) = kmin
  17.             End If
  18.         End If
  19.     Next
  20.     [e20].Resize(n, 5) = brr
  21. End Sub
复制代码

评分

参与人数 1 +9 收起 理由
laoau138 + 9 来学习

查看全部评分

回复

使用道具 举报

发表于 2017-6-22 21:39 | 显示全部楼层
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-28 20:19 , Processed in 0.430511 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表