ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
数据管理利器Foxtable2022下载 Excel 2016函数公式学习大典 Office知识技巧免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 Power Query数据清洗实战攻略 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 295|回复: 36

[已解决] 有条件提取不重复值,谢谢shiruiqiang、aecn、笨鸟飞不高、liulang0808,ykcbf1100老

[复制链接]

TA的精华主题

TA的得分主题

发表于 2021-10-13 16:02 | 显示全部楼层 |阅读模式
本帖最后由 lhj323323 于 2021-10-15 11:28 编辑

老师:
上传的附件中有写好的程序
是关于提取不重复值,但我现在需要加一个限制条件
老师如有空,请帮我看看
先谢谢了
求助2.rar (12.63 KB, 下载次数: 18)

TA的精华主题

TA的得分主题

发表于 2021-10-13 16:25 | 显示全部楼层
本帖最后由 笨鸟飞不高 于 2021-10-13 16:43 编辑

求助2.zip (19.76 KB, 下载次数: 13)
更新

评分

参与人数 2鲜花 +3 收起 理由
ynymzzr + 2 优秀作品
hellikawhi2 + 1 优秀作品

查看全部评分

TA的精华主题

TA的得分主题

发表于 2021-10-13 16:34 | 显示全部楼层
本帖最后由 mianhuaqiu 于 2021-10-13 17:06 编辑

1111111111111

TA的精华主题

TA的得分主题

发表于 2021-10-13 16:41 | 显示全部楼层
新手尝试了一下

求助2.xls.zip

18.21 KB, 下载次数: 10

评分

参与人数 1鲜花 +2 收起 理由
lhj323323 + 2 感谢帮助

查看全部评分

TA的精华主题

TA的得分主题

发表于 2021-10-13 16:53 | 显示全部楼层
加个条件
  1. If Left(Format(stra, "000000"), 1) <> 2 And Left(Format(stra, "000000"), 1) <> 9 Then
复制代码

Sub test()
  Dim Myr%
  Dim Arr, Brr
  Dim d2 As Object, d3 As Object
  Set d2 = CreateObject("scripting.dictionary")
  Set d3 = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
With Sheet1
      Myr = .Cells(.Rows.Count, 1).End(xlUp).Row
      Arr = .Range("a1:a" & Myr) '股票代码
      Brr = .Range("b1:b" & Myr) '股票名称
     .Range("c:c").ClearContents
End With
Dim stra$, strb$
If Myr < 2 Then Exit Sub  '无数据则退出
'1按A列提不取重复的股票代码
    For Myr = LBound(Brr) To UBound(Brr)
        stra = Trim(CStr(Arr(Myr, 1)))
        strb = Trim(CStr(Brr(Myr, 1)))
        If Left(Format(stra, "000000"), 1) <> 2 And Left(Format(stra, "000000"), 1) <> 9 Then
            If stra <> "" And strb <> "" Then
                If d2.exists(stra) Then
                    '如果已存在数据,且名称不同,则加入新名称
                   If d2(stra) <> strb Then
                      d2(stra) = strb
                      d3(stra) = d3(stra) & "," & strb
                   End If
                Else
                    '如果是首次,则直接写入
                   d2(stra) = strb
                   d3(stra) = strb
                End If
            End If
        End If
    Next
With Sheet1
    .Columns(3).NumberFormatLocal = "000000"
    .Range("c1").Resize(d3.Count) = Application.WorksheetFunction.Transpose(d3.keys)
    .Range("d1").Resize(d3.Count) = Application.WorksheetFunction.Transpose(d3.items)
    .Select
End With
Application.ScreenUpdating = True
End Sub

评分

参与人数 1鲜花 +2 收起 理由
lhj323323 + 2 感谢帮助

查看全部评分

TA的精华主题

TA的得分主题

发表于 2021-10-13 17:00 | 显示全部楼层
本帖最后由 mianhuaqiu 于 2021-10-13 17:06 编辑


在你的代码下面加上这段

TA的精华主题

TA的得分主题

发表于 2021-10-13 17:01 | 显示全部楼层

Dim i%, j%

    j = Worksheets("数据源").Range("c60000").End(xlUp).Row
    For i = 1 To j
   
If Left(Cells(i, 3), 1) = 2  Or Left(Cells(i, 3), 1) = 9 Then
Range(Cells(i, 3), Cells(i, 4)).Select
   Selection.Delete Shift:=xlUp
  i = i - 1
End If
Next

TA的精华主题

TA的得分主题

发表于 2021-10-13 17:02 | 显示全部楼层
If Left(Cells(i, 3), 1) = 2 Or Left(Cells(i, 3), 1) = 9 Then
Range(Cells(i, 3), Cells(i, 4)).Select
   Selection.Delete Shift:=xlUp
  i = i - 1
End If
Next

TA的精华主题

TA的得分主题

发表于 2021-10-13 17:04 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2021-10-13 17:12 | 显示全部楼层
  1. Sub gj23w98()
  2.     Set d = CreateObject("scripting.dictionary")
  3.     ar = [a1].CurrentRegion
  4.     ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
  5.     For i = 1 To UBound(ar)
  6.         If Left(ar(i, 1), 1) <> 2 And Left(ar(i, 1), 1) <> 9 Then
  7.             If Not d.exists(ar(i, 1)) Then
  8.                 m = m + 1
  9.                 d(ar(i, 1)) = m
  10.                 br(m, 1) = ar(i, 1)
  11.                 br(m, 2) = ar(i, 2)
  12.             Else
  13.                 br(d(ar(i, 1)), 2) = br(d(ar(i, 1)), 2) & "," & ar(i, 2)
  14.             End If
  15.         End If
  16.     Next
  17.     If m > 0 Then
  18.         Columns(3).NumberFormatLocal = "000000"
  19.         [c1].Resize(m, UBound(br, 2)) = br
  20.     End If
  21. End Sub
复制代码
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,每天学会一个新技能

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2021-10-25 06:57 , Processed in 0.100369 second(s), 15 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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