希望通过vba实现在原文档里将每一个单位名称复制到对应的“情况”后面

wt29106 · 发表于 2020-6-2 17:14

青莲山地区企业发展基本情况

1. 单位名称：青湖智海奶牛养殖场大型企业

员工数量情况：500人及以上，直接吸纳、带动周边就业人员300人以上。

地理位置情况：青湖山西北地缘，因道路扩建部分场区将向北搬迁。

生产经营情况：资金链正常，（有、无√）不良信贷记录。

2.单位名称：光海水产批发市场中、小型企业

从业人员数量情况：不足100人，多为当地居民。

地理位置情况：火车站旁，地处人流量较大地段，地理位置优越。

经营情况：资金运转正常，（有、无√）不良信贷记录。

3.单位名称：双富仁玻璃厂中、小型企业

员工数量情况：150人，民办企业，直接吸纳、带动周边就业人员50人。

地理位置情况：城北工业园区入口处，属于规划绿色区块地段。

生产经营情况：运转资金仅够维持三个月，（有、无√）不良信贷记录。

4.单位名称：福昕攀锦运来不锈钢厂中、小型企业

已注销营业执照，待资产评估。

5.单位名称：凤英普惠食品加工基地中、小型企业

员工数量情况：200人，再就业人员10人。

地理位置情况：城北路1035号，距汽车站500米。

生产经营情况：资金运转正常，（有、无√）不良信贷记录。

6.单位名称：美智体四维培训中、小型企业

人员情况：80人，就业困难群体5人。

位置情况：团结路1582号。

经营情况：资金运转正常，（有、无√）不良信贷记录。

7.单位名称：美尔雅在线医疗中、小型企业

现有人员情况：160人，就业困难群体2人。

位置情况：幸福路25-3号。

经营情况：资金运转正常，（有√、无）不良信贷记录。

8.单位名称：美美与共印刷厂中、小型企业

现有人员情况：110人，就业困难群体3人。

位置情况：幸福路128-1号。

经营情况：资金运转正常，（有√、无）不良信贷记录。

9.单位名称：勤达管家物业公司中、小型企业

现有人员情况：170人，吸纳当地就业65人。

位置情况：中心北路2088号。

经营情况：资金运转正常，（有√、无）不良信贷记录。

10.单位名称：诚美云恒饰品公司中、小型企业

现有人员情况：120人，就业困难群体1人。

位置情况：幸福路356-2号。

经营情况：资金运转正常，（有√、无）不良信贷记录。

希望通过vba达到的效果如下：（就是在“情况”这个词后面把对应的单位名称粘贴上就行）

青莲山地区企业发展基本情况

1. 单位名称：青湖智海奶牛养殖场大型企业

员工数量情况青湖智海奶牛养殖场：500人及以上，直接吸纳、带动周边就业人员300人以上。

地理位置情况青湖智海奶牛养殖场：青湖山西北地缘，因道路扩建部分场区将向北搬迁。

生产经营情况青湖智海奶牛养殖场：资金链正常，（有、无√）不良信贷记录。

2.单位名称：光海水产批发市场中、小型企业

从业人员数量情况光海水产批发市场：不足100人，多为当地居民。

地理位置情况光海水产批发市场：火车站旁，地处人流量较大地段，地理位置优越。

经营情况光海水产批发市场：资金运转正常，（有、无√）不良信贷记录。

3.单位名称：双富仁玻璃厂中、小型企业

员工数量情况双富仁玻璃厂：150人，民办企业，直接吸纳、带动周边就业人员50人。

地理位置情况双富仁玻璃厂：城北工业园区入口处，属于规划绿色区块地段。

生产经营情况双富仁玻璃厂：运转资金仅够维持三个月，（有、无√）不良信贷记录。

4.单位名称：福昕攀锦运来不锈钢厂中、小型企业

已注销营业执照，待资产评估。

5.单位名称：凤英普惠食品加工基地中、小型企业

员工数量情况凤英普惠食品加工基地：200人，再就业人员10人。

地理位置情况凤英普惠食品加工基地：城北路1035号，距汽车站500米。

生产经营情况凤英普惠食品加工基地：资金运转正常，（有、无√）不良信贷记录。

6.单位名称：美智体四维培训中、小型企业

人员情况美智体四维培训：80人，就业困难群体5人。

位置情况美智体四维培训：团结路1582号。

经营情况美智体四维培训：资金运转正常，（有、无√）不良信贷记录。

7.单位名称：美尔雅在线医疗中、小型企业

现有人员情况美尔雅在线医疗：160人，就业困难群体2人。

位置情况美尔雅在线医疗：幸福路25-3号。

经营情况美尔雅在线医疗：资金运转正常，（有√、无）不良信贷记录。

8.单位名称：美美与共印刷厂中、小型企业

现有人员情况美美与共印刷厂：110人，就业困难群体3人。

位置情况美美与共印刷厂：幸福路128-1号。

经营情况美美与共印刷厂：资金运转正常，（有√、无）不良信贷记录。

9.单位名称：勤达管家物业公司中、小型企业

现有人员情况勤达管家物业公司：170人，吸纳当地就业65人。

位置情况勤达管家物业公司：中心北路2088号。

经营情况勤达管家物业公司：资金运转正常，（有√、无）不良信贷记录。

10.单位名称：诚美云恒饰品公司中、小型企业

现有人员情况诚美云恒饰品公司：120人，就业困难群体1人。

位置情况诚美云恒饰品公司：幸福路356-2号。

经营情况诚美云恒饰品公司：资金运转正常，（有√、无）不良信贷记录。

413191246se · 发表于 2020-6-4 00:33

楼主，我觉得你不太讲究，各个“情况”字数不太一样啊！

413191246se · 发表于 2020-6-4 02:22

* 楼主，我一向是比较讲究的人，请试用下面代码：（有一项例外，请楼主自己在那个取消营业执照的企业前面加上“【生产经营】”即可）

Sub test()
With ActiveDocument.Content
With .Font
.NameFarEast = "宋体"
.NameAscii = "Times New Roman"
.ColorIndex = wdAuto
End With
With .Find
.Execute "名称:", , , 1, , , , , , "名称：", 2
.Execute "情况:", , , 1, , , , , , "情况：", 2
End With
End With
Dim i As Paragraph
For Each i In ActiveDocument.Paragraphs
If i.Range Like "*：*" Then
ActiveDocument.Range(Start:=i.Range.Start, End:=i.Range.Characters(InStr(i.Range, "：")).End).Select
If Selection Like "*单位名称：*" Then
Selection.Delete
Selection.InsertAfter Text:="【单位名称】"
i.Range.Font.Bold = True
i.Range.Font.ColorIndex = wdRed
i.Range.Font.Name = "黑体"
i.Range.InsertParagraphBefore
i.Range.InsertParagraphBefore
ElseIf Selection Like "*员工*情况：*" Or Selection Like "*数量*情况：*" Or Selection Like "*从业*情况：*" Or Selection Like "*人员*情况：*" Then
Selection.Delete
Selection.InsertAfter Text:="【员工数量】"
Selection.Font.Bold = True
i.Range.Font.ColorIndex = wdGreen
ElseIf Selection Like "*地理*情况：*" Or Selection Like "*位置*情况：*" Then
Selection.Delete
Selection.InsertAfter Text:="【地理位置】"
Selection.Font.Bold = True
i.Range.Font.ColorIndex = wdDarkRed
ElseIf Selection Like "*生产*情况：*" Or Selection Like "*经营*情况：*" Then
Selection.Delete
Selection.InsertAfter Text:="【生产经营】"
Selection.Font.Bold = True
i.Range.Font.ColorIndex = wdBlue
Else
i.Range.InsertBefore Text:="【生产经营】"
End If
End If
Next
For Each i In ActiveDocument.Paragraphs
If i.Range Like "【单位名称】*" Then
If i.Range Like "* *" Then
i.Range.Characters(InStr(i.Range, " ")).Select
Selection.InsertParagraphBefore
Selection.MoveStart
Do While Selection.Characters(1).Text = " "
Selection.Characters(1).Delete
Selection.Paragraphs(1).Range.Select
Loop
Selection.InsertBefore Text:="【企业规模】"
With Selection.Font
.ColorIndex = wdPink
.NameFarEast = "宋体"
.NameAscii = "Times New Roman"
.Bold = False
End With
ActiveDocument.Range(Start:=Selection.Start, End:=Selection.Characters(InStr(Selection, "】")).End).Bold = True
End If
End If
Next
With ActiveDocument.Paragraphs(1).Range.ParagraphFormat
.Style = wdStyleHeading1
.Alignment = wdAlignParagraphCenter
End With
Selection.HomeKey 6
' ActiveDocument.Content.Font.ColorIndex = wdAuto'字体颜色（自动色）
End Sub

复制代码

413191246se · 发表于 2020-6-4 02:23

* 如果楼主不想要各种颜色，或想打印，只须将代码倒数第二行前面的小撇号删除即可变为黑色。

wt29106 · 发表于 2020-6-4 16:54

413191246se 发表于 2020-6-4 02:23
* 如果楼主不想要各种颜色，或想打印，只须将代码倒数第二行前面的小撇号删除即可变为黑色。

感谢413191246se大神的深夜回复，代码运行速度很快，作用后的文档颜色很靓丽，（有个小发现就是运行2遍程序就可以把彩色文字变成正常）作为一个不太讲究的人，必须给您点赞，只是有一点，程序运行后没能将对应的单位名称复制过来，有些遗憾。再次感谢413191246se大神的关注希望下面这段文字能带给您温暖
当久违的阳光

拂过大地的脸庞

当体内的温度

慢慢回升越过零点

当和煦的清风

轻柔地滑过面颊

我的世界不再孤独

在这盛夏的傍晚

一场不期而遇的雨水过后

叶子翠绿欲滴

阳光透过翠绿的渲染洒在一棵三叶草上

有了岁月的积淀

脸上的皱纹舒展了

调皮的风带着雨水的清凉

将快乐的种子播撒开来

心里满满的

都是对岁月的思念

wt29106 · 发表于 2020-6-4 17:16

本帖最后由 wt29106 于 2020-6-4 19:25 编辑

顶起来，顶起来

413191246se · 发表于 2020-6-4 22:28

* 楼主，谢谢夸奖！——不是做不到，是不想。因为，你所要求的那种情况，有什么意义呢？很难看的。
* 如果是你们头儿要求的，你可以把现在的运行结果给你们头儿看，这样才清晰、鲜明嘛！
* 如果要统计有多少家企业，可以将“企业名称”替换为“企业名称”或其它，看看有多少个替换了，但不要保存。
* 建议程序只运行一次保存即可，再稍加检查即可（请以后都照此模式抄写，你原来的要求效果很难看的）。
* 记住：请一定要追求格式美丽、清新！

wt29106 · 发表于 2020-6-5 10:38

413191246se 发表于 2020-6-4 22:28
* 楼主，谢谢夸奖！——不是做不到，是不想。因为，你所要求的那种情况，有什么意义呢？很难看的。
* 如果 ...

如果您能将单位名称复制到对应的“情况”后的话还请伸出援手，因为我们主任太死板了，按照代码运行的文档很简洁、清晰、明了不过主任那里并不认可，还望老师能出手相助，感谢！感谢！感谢！

413191246se · 发表于 2020-6-6 01:24

楼主，好吧！按照你原来的意思，请试用下面的代码：（旧 test 宏请删除！）

Sub test()
Dim i As Paragraph, j$, k$, t$
k = MsgBox("<是>：X <否>：[X] <取消>：/X", vbYesNoCancel + vbExclamation, "请选择样式！")
With ActiveDocument
With .Content.Find
.Execute "名称:", , , 1, , , , , , "名称：", 2
.Execute "情况:", , , 1, , , , , , "情况：", 2
.Execute "^s", , , 1, , , , , , " ", 2
.Execute "^t", , , 1, , , , , , " ", 2
.Execute "　", , , 1, , , , , , " ", 2
End With
For Each i In .Paragraphs
With i.Range
If .Text Like "*单位名称：*[ ^t]*" Then
.Characters(InStr(i.Range, "：")).Select
With Selection
.MoveEndUntil cset:=" "
.MoveStart
j = .Text
If k = vbNo Then .Text = "[" & .Text & "]"
End With
ElseIf .Text Like "*情况：*" Then
If k = vbYes Then
t = j
ElseIf k = vbNo Then
t = "[" & j & "]"
Else
t = "/" & j
End If
.Characters(InStr(i.Range, "：")).InsertBefore Text:=t
End If
End With
Next
End With
Selection.HomeKey 6
End Sub

复制代码

wt29106 · 发表于 2020-6-8 12:42

413191246se 发表于 2020-6-6 01:24
楼主，好吧！按照你原来的意思，请试用下面的代码：（旧 test 宏请删除！）

再次感谢413191246se的关注，第二次的代码运行时提示作用“execute”作用于“find”对象时失败，经过调试我把第八行代码删去后一次成功，完全满足要求，从代码中可以看出413191246se老师是个极讲究又很细心的人，考虑的很周全。真是太强大了！！！
另外还有一个问题想请教下老师，在使用word是我经常需要复制不连续的内容到剪贴板，常见的做法就是按住“ctrl”加鼠标选中，想知道在vba里有对应不连续选中的方法吗，比如还是原贴里需要将单位名称和对应的“情况”后的内容复制到剪贴板里面。

		自动登录	找回密码
密码			免费注册

[求助] 希望通过vba实现在原文档里将每一个单位名称复制到对应的“情况”后面

评分

评分

评分