ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 Office知识技巧免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 282|回复: 9

[求助] 求VBA代码,快速生成词语列表。

[复制链接]

TA的精华主题

TA的得分主题

发表于 2020-3-14 22:52 | 显示全部楼层 |阅读模式
本帖最后由 hqxx1234 于 2020-3-15 09:00 编辑

词语提取0314.rar (172.48 KB, 下载次数: 7)

TA的精华主题

TA的得分主题

发表于 2020-3-15 03:40 | 显示全部楼层
总的意思是先匹配出所有符合条件的再从里面随机抽取一个放入单元格?

TA的精华主题

TA的得分主题

发表于 2020-3-15 05:45 | 显示全部楼层
  1. Sub ts()
  2. rr = Sheet1.UsedRange.Rows.Count
  3. arr = Sheet1.Range("a1:b" & rr)
  4. zdh = Cells(Rows.Count, 2).End(3).Row
  5. For w = 2 To zdh
  6. brr = Sheet1.Range("l1:t1")
  7. l = 1: m = 1: n = 1: o = 1: p = 1: q = 1: r = 1
  8. For i = 1 To rr
  9. If arr(w, 2) = "" Then Exit For
  10. jx = arr(i, 1)
  11. jx1 = InStr(jx, arr(w, 2))
  12. If Len(jx) = 2 And jx1 = 1 And l = 1 Then
  13. brr(1, 1) = jx
  14. l = l + 1
  15. ElseIf Len(jx) = 2 And jx1 = 1 And l = 2 Then
  16.   brr(1, 2) = jx
  17.   ElseIf Len(jx) = 2 And jx1 = 2 And m = 1 Then
  18.   brr(1, 3) = jx
  19.   m = m + 1
  20.   ElseIf Len(jx) = 2 And jx1 = 2 And m = 2 Then
  21.   brr(1, 4) = jx
  22.   ElseIf Len(jx) = 4 And jx1 = 1 And n = 1 Then
  23.   brr(1, 5) = jx
  24.   ElseIf Len(jx) = 4 And jx1 = 2 And o = 1 Then
  25.   brr(1, 6) = jx
  26.   ElseIf Len(jx) = 4 And jx1 = 3 And p = 1 Then
  27.   brr(1, 7) = jx
  28.   ElseIf Len(jx) = 4 And jx1 = 4 And q = 1 Then
  29.   brr(1, 8) = jx
  30.   ElseIf Len(jx) = 3 And jx1 And r = 1 Then
  31.    brr(1, 9) = jx
  32. End If
  33.    Next
  34.    Sheet1.Range(Cells(w, 3), Cells(w, 11)) = brr
  35.    Next
复制代码

不随机,只取查找到的第一个,CD EF分别取第一个跟第二个,没有第二个值就留空

评分

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

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-3-15 08:57 来自手机 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-3-15 09:02 来自手机 | 显示全部楼层
sj15627581616 发表于 2020-3-15 05:45
不随机,只取查找到的第一个,CD EF分别取第一个跟第二个,没有第二个值就留空

抽空帮我考虑一下随机提取,辛苦

TA的精华主题

TA的得分主题

发表于 2020-3-15 09:10 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2020-3-15 09:31 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2020-3-15 09:54 | 显示全部楼层
本帖最后由 cqz1314 于 2020-3-15 10:17 编辑

期待学习一下

TA的精华主题

TA的得分主题

发表于 2020-3-16 07:27 | 显示全部楼层
本帖最后由 sj15627581616 于 2020-3-17 08:16 编辑

利用随机函数对内容进行排序打乱再读取,每运行一次打乱一次顺序以达到随机抽取的目的,重新修改了下代码上附件了

词语提取0314.rar

426.29 KB, 下载次数: 2

评分

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

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-3-17 08:13 | 显示全部楼层
Sub tx()
ss = Timer
Application.ScreenUpdating = False: Application.DisplayAlerts = False
'关闭屏幕刷新以及确认提示,默认为确认
rr = Sheet1.UsedRange.Rows.Count
'获取工作表1已使用单元格的最大行号
arr = Sheet1.Range("a1:a" & rr)
'将工作表1指定范围赋值给数组arr
Sheets.Add
    ActiveSheet.Name = "临时存放"
    '新建一个工作表,并且命名为"临时存放"
Sheets("临时存放").Range("a1:a" & rr) = arr
'在"临时存放"工作表A列与数组同等大小范围赋值数组
For i = 1 To rr
arr(i, 1) = Rnd
Next
'建立一个循环,对数组内容使用Rnd函数进行随机赋值
Sheets("临时存放").Range("b1:b" & rr) = arr
'在"临时存放"工作表B列与数组同等大小范围赋值数组
Sheets("临时存放").Range("a1:b" & rr).Select
'选择"临时存放"工作表A B两列已使用单元格
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Sheets("临时存放").Range("b1:b" & rr), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:=""
        End With
        .Header = xlNo
        .Orientation = xlSortColumns
        .MatchCase = False
        .SortMethod = xlPinYin
        .SetRange Rng:=Selection
        .Apply
    End With
    '对两列内容根据B列数值重新进行排序
arr = Sheets("临时存放").Range("a1:a" & rr)
''将工作表"临时存放" 指定范围赋值给数组arr
Sheets("临时存放").Delete
'删除工作表 "临时存放"
Sheet1.Activate
'激活工作表1
zdh = Cells(Rows.Count, 2).End(3).Row
'获取当前工作表B列最大非空行号并赋值给zdh
Range("c2:k" & zdh).ClearContents '清除单元格内容,不清除格式
brr = Range("b2:k" & zdh)
For w = 2 To zdh
'创建一个名为brr只有6列一行的数组,该数组内容默认为空,所以赋值内容位置一定为空
l = 1: m = 1: n = 1: o = 1: p = 1: q = 1: r = 1
'lmnopqr均赋值数值1,用于计数用
For i = 1 To rr
If brr(w - 1, 1) = "" Then Exit For
'如果B列该行内容为空置,那么退出本次循环
jx = arr(i, 1) '简写,对后续代码简化
jx1 = InStr(jx, brr(w - 1, 1)) '判断数组内容是否包含B列当前内容,并且进行简写
If l = 3 And m = 3 And n = 2 And o = 2 And p = 2 And q = 2 And r = 2 Then Exit For
'当所有计数均符合条件时,退出本次循环,该代码目的为了较少
If Len(jx) = 2 And jx1 = 1 And l = 1 Then
brr(w - 1, 2) = jx
l = l + 1
ElseIf Len(jx) = 2 And jx1 = 1 And l = 2 Then
  brr(w - 1, 3) = jx
  l = w + 1
  ElseIf Len(jx) = 2 And jx1 = 2 And m = 1 Then
  brr(w - 1, 4) = jx
  m = m + 1
  ElseIf Len(jx) = 2 And jx1 = 2 And m = 2 Then
  brr(w - 1, 5) = jx
  m = m + 1
  ElseIf Len(jx) = 4 And jx1 = 1 And n = 1 Then
  brr(w - 1, 6) = jx
  n = n + 1
  ElseIf Len(jx) = 4 And jx1 = 2 And o = 1 Then
  brr(w - 1, 7) = jx
  o = o + 1
  ElseIf Len(jx) = 4 And jx1 = 3 And p = 1 Then
  brr(w - 1, 8) = jx
  p = p + 1
  ElseIf Len(jx) = 4 And jx1 = 4 And q = 1 Then
  brr(w - 1, 9) = jx
  q = q + 1
  ElseIf Len(jx) = 3 And jx1 And r = 1 Then
   brr(w - 1, 10) = jx
   r = r + 1
End If
'对符合条件的内容写进数组brr对应位置
   Next
   Next
   
   For i = 1 To zdh - 1
If brr(i, 1) <> "" Then
For e = 10 To 2 Step -1
If e > 5 And brr(i, e) = "" Then
brr(i, e) = "★"
ElseIf brr(i, e) = "" And e = 5 Then
If brr(i, e - 1) = "" Then
brr(i, e) = "★"
Else
brr(i, e) = "◆"
End If
ElseIf brr(i, e) = "" And e = 4 Then
brr(i, e) = "★"
ElseIf brr(i, e) = "" And e = 3 Then
If brr(i, e - 1) = "" Then
brr(i, e) = "★"
Else
brr(i, e) = "◆"
End If
ElseIf brr(i, e) = "" And e = 2 Then
brr(i, e) = "★"
End If
Next
End If
'判断数组内容空值内容,分别赋值"★"或"◆"
Next
Range("b2:k" & zdh) = brr
'将数组内容释放给对应单元格
   Application.ScreenUpdating = True: Application.DisplayAlerts = True '开启屏幕刷新以及确认提示
   MsgBox Timer - ss
End Sub

评分

参与人数 1鲜花 +2 收起 理由
hqxx1234 + 2 太强大了

查看全部评分

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

本版积分规则

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

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

GMT+8, 2020-5-29 18:41 , Processed in 0.100124 second(s), 20 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

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