ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
楼主: 666611430

[求助] 怎么对选中的每一个单词实现如下效果(不知能否实现)?

[复制链接]

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-4-30 22:50 | 显示全部楼层
sylun 发表于 2020-4-30 20:58
可试试如下代码:

非常感谢兄弟,这代码可以基本上完成了我的工作了。
就唯一一个部分是:如果连续选中的话它对整个选中内容实现效果了。我的工作是这样的,对于连续选中内容也对单词实现效果。如图所示
3.png
如图所示,对连续选中的内容,也对单个单词完成上述效果。 大佬,有空再看一下。谢谢。

TA的精华主题

TA的得分主题

发表于 2020-5-1 13:48 | 显示全部楼层
楼主如果在原示范图片中的多个选定内容中至少有一个是选定两个以上单词,就不会产生这样的误导。我前面的代码中对无选定内容时就是针对多个单词进行处理的,楼主可参考该处理方法对选定情形的查找代码段中的文本内容进行处理,其实就是对Range对象的的words集合的处理

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-5-1 14:27 | 显示全部楼层
sylun 发表于 2020-5-1 13:48
楼主如果在原示范图片中的多个选定内容中至少有一个是选定两个以上单词,就不会产生这样的误导。我前面的代 ...

因自己疏忽将把这个情况给漏掉了。我对words集合处理不太熟悉,望兄弟再帮我修改一下。我这个工作非常需要这个代码了。谢谢兄弟。

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-5-1 22:51 | 显示全部楼层
我自己调试了老半天也没调试出来。请兄弟帮我忙一个了,让你再次费心了。先谢谢你

TA的精华主题

TA的得分主题

发表于 2020-5-1 23:26 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
重新修改了代码,楼主可试试
  1. Sub test2()
  2.     Dim oRange As Range
  3.    
  4.     Application.ScreenUpdating = False
  5.     Options.DefaultHighlightColorIndex = 7 'wdYellow
  6.     With Selection
  7.         If .Type = 1 Then
  8.             Set oRange = .Range
  9.             .Expand 4  '暂扩展到段落;如到全文,参数6
  10.             Inserting .Range
  11.             oRange.Select
  12.         ElseIf .Type = 2 Then
  13.             Dialogs(742).Execute
  14.             With ActiveDocument.Content.Find
  15.                 .Highlight = True
  16.                 Do While .Execute
  17.                     With .Parent
  18.                         If .Text Like "*[0-9A-Za-z]*" Then
  19.                             .End = Inserting(.Duplicate)
  20.                             .Editors.Add -1
  21.                             .Collapse 0
  22.                         End If
  23.                     End With
  24.                 Loop
  25.                 .Replacement.Highlight = False
  26.                 .Parent.WholeStory
  27.                 .Execute Replace:=2
  28.             End With
  29.             ActiveDocument.SelectAllEditableRanges -1
  30.             ActiveDocument.DeleteAllEditableRanges -1
  31.         End If
  32.     End With
  33.     Application.ScreenUpdating = True
  34.     MsgBox "Ok!"
  35. End Sub

  36. Function Inserting(myRange As Range) As Long
  37.     Dim i As Integer
  38.     With myRange
  39.         If .Characters.First = Chr(32) Then .Start = .Start + 1
  40.         For i = .Words.Count To 1 Step -1
  41.             With .Words(i)
  42.                 If Right(.Text, 1) = Chr(32) Then .End = .End - 1
  43.                 If .Text Like "*[0-9A-Za-z]*" Then
  44.                     .Text = .Text & "(" & Trim(.Text) & ",长度为:" & Len(.Text) & ")"
  45.                 End If
  46.             End With
  47.         Next
  48.         Inserting = .End
  49.     End With
  50. End Function
复制代码

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-5-2 10:08 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
sylun 发表于 2020-5-1 23:26
重新修改了代码,楼主可试试

谢谢兄弟的关注和协助。
现在两种情况,完美解决了,即1.无选中任何内容2。连续选中。

但是对于如图所示的情况不对了。请指示一下代码怎么修改。最好让兄弟亲自修改一下。谢谢
1.png


2.png

TA的精华主题

TA的得分主题

发表于 2020-5-2 22:48 | 显示全部楼层
666611430 发表于 2020-5-2 10:08
谢谢兄弟的关注和协助。
现在两种情况,完美解决了,即1.无选中任何内容2。连续选中。

15楼代码确实有问题,修改如下,请再测试:
  1. Sub test2()
  2.     Dim i As Integer
  3.     Dim oRange As Range
  4.    
  5.     Application.ScreenUpdating = False
  6.     Options.DefaultHighlightColorIndex = 7 'wdYellow
  7.     With Selection
  8.         If .Type = 1 Then
  9.             Set oRange = .Range
  10.             .Expand 4  '暂扩展到段落;如到全文,参数6
  11.             Inserting .Range
  12.             oRange.Select
  13.         ElseIf .Type = 2 Then
  14.             Dialogs(742).Execute
  15.             With ActiveDocument.Content.Find
  16.                 .Highlight = True
  17.                 Do While .Execute
  18.                     With .Parent
  19.                         If .Text Like "*[0-9A-Za-z]*" Then
  20.                             .End = Inserting(.Duplicate).End
  21.                             .Editors.Add -1
  22.                             .Collapse 0
  23.                         End If
  24.                     End With
  25.                 Loop
  26.                 .Replacement.Highlight = False
  27.                 .Parent.WholeStory
  28.                 .Execute Replace:=2
  29.             End With
  30.             ActiveDocument.SelectAllEditableRanges -1
  31.             ActiveDocument.DeleteAllEditableRanges -1
  32.         End If
  33.     End With
  34.     Application.ScreenUpdating = True
  35.     MsgBox "Ok!"
  36. End Sub

  37. Function Inserting(myRange As Range) As Range
  38.     Dim i As Integer
  39.     Dim n As Integer
  40.    
  41.     With myRange
  42.         If .Characters.First = Chr(32) Then .Start = .Start + 1
  43.         n = .Words.Count
  44.         For i = n To 1 Step -1
  45.             With .Words(i)
  46.                 If Right(.Text, 1) = Chr(32) Then .End = .End - 1
  47.                 If .Text Like "*[0-9A-Za-z]*" Then
  48.                     .Text = .Text & "(" & Trim(.Text) & ",长度为:" & Len(.Text) & ")"
  49.                 End If
  50.                 If i = n Then Set Inserting = .Duplicate
  51.             End With
  52.         Next
  53.     End With
  54. End Function
复制代码

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-5-2 23:25 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
sylun 发表于 2020-5-2 22:48
15楼代码确实有问题,修改如下,请再测试:

谢谢兄弟关注和协助。问题已解决!

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-5-21 15:56 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
sylun 发表于 2020-4-30 20:58
可试试如下代码:

现在头儿又让我把效果修改成如下。由于自己编写能力很差劲,捣鼓了好几天,也没有把效果实现了。希望兄弟再一次帮忙我一下,我的工作非常需要的,麻烦你了。为此表示不胜感激。真的很需要兄弟的帮忙。新要求如下。
1.png
--------------------------------------------------------
***正文最后显示效果***
1.单词的选择方式与本帖选中方式一样。
2.加序号
3.若有重复单词,只保留一个。
4.加对单词拆分,效果如上图所示。
5.如图红线所示距离以一个TAB隔开
6.选中单词的出现次数
----------------------------------------------------------
期待兄弟帮我修改一下代码。等你回复。




TA的精华主题

TA的得分主题

 楼主| 发表于 2020-5-30 20:21 | 显示全部楼层
本帖最后由 666611430 于 2020-5-30 20:22 编辑
sylun 发表于 2020-5-2 22:48
15楼代码确实有问题,修改如下,请再测试:

兄弟,真的很需要你再一次抽空帮我实现以下19楼的效果。真的很期待你帮忙。这对我的工作非常需要的。谢谢。
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-3-29 22:45 , Processed in 0.054998 second(s), 8 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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