从原文档里复制企业名称和具体问题项粘贴到新的空白文档里或者复制到剪贴板

wt29106 · 发表于 2020-6-10 10:42

企业自检自查情况

1、自检自查单位：志友熟食品加工有限公司 中小型企业

检查时间：4月26号

检查人:张三、李四、王五

在岗人员：高某杰

存在问题（共计9个）：

（一）安全生产方面（3个问题）

1. 吊装作业时无人指挥，作业人员劳保着装不全。

2. 吊装作业未办理作业票。

3. 厂房内配电箱下未铺设绝缘胶垫。

（二）压力（消防）器材管理方面（6个问题）

4. 厂房内在用氧气瓶压力表未定期校验。

5. 厂房工作区，灭火器配备不足。

6. 生产厂区内有害气体报警仪未通电，不能正常使用。

7. 压力容器管理台账填写不规范。

8. 5具灭火器压力不足。

9. 调度室内1具二氧化碳灭火器未配备防护手套。

整改期限:立查立改。

4、自检自查单位：北京新思路运输有限公司二分公司大型企业

检查时间：4月30号

检查人:张三、李四、王五

在岗人员：王某荣

存在问题（共计4个）：

（一）安全生产方面（4个问题）

1. 配电箱周围堆放可燃杂物。

2. 私自接线，电源线头裸露，无防护措施。

3. 存在超负荷用电且无漏电保护装置。

4. 前期自检自查发现的问题未及时整改。

整改期限:5天，

5、自检自查单位：新番齐瑞达特种装备制造有限责任公司公司 大型企业

检查时间：4月30号

检查人:张三、李四、王五

在岗人员：李某

存在问题（共计1个）：

（二）压力（消防）器材管理方面（1个问题）

院内1具灭火器压力不足。

整改期限:立查立改。

7、自检自查单位：七彩会心钢材卷制厂 大型企业

检查时间：4月30号

检查人:张三、李四、王五

在岗人员：罗某兵

存在问题（共计1个）：

（一）安全生产方面（1个问题）

大厅内1具灭火器未定期检查。

整改期限:1天。

13、自检自查单位：海油创托北部服务中心站 大型企业

检查时间：5月2号

检查人:张三、李四、王五

在岗人员：李某江

检查情况：暂未发现问题隐患。

14、自检自查单位：中船建设公司 大型企业

检查时间：5月3号

检查人:张三、李四、王五

在岗人员：梁某友

存在问题（共计6个）：

（一）安全生产方面（1个问题）

1. 特种设备未定期检验。

（二）压力（消防）器材管理方面（2个问题）

2.2具灭火器压力不符合要求。

3. 压力容器台账填写不规范。

（三）车辆管理方面（3个问题）

4.车载灭火器压力不足，无检验卡。

5.车辆轮胎大面积破损，

6.驾驶员未体检。

整改期限:5天。

19、自检自查单位：中兴自来水厂 大型企业

检查时间：5月4号

检查人:张三、李四、王五

在岗人员：高某安

存在问题（共计2个）：

（一）安全生产方面（2个问题）

1.未建立自检自查制度。

2.部分防护装备过期。

整改期限:立查立改。

23、自检自查单位：新家园工程有限公司 中小型企业

检查时间：5月1号查

检查人:张三、李四、王五

在岗人员：周某萱

存在问题（共计6个）

（一）安全生产方面（5个问题）

1. 公司主要领导对安全工作不重视，不清楚自身安全职责。

2. 工作人员在禁烟区吸烟。

3. 特种作业人员无证上岗。

4. 特种设备未定期检验。

5. 自检自查台账有漏项。

（二）车辆管理方面（1个问题）

6. 1台特种车辆未年检。

整改期限:限期10天。

27、自检自查单位：达伽马运输公司 中小型企业

检查时间：5月1号

检查人:张三、李四、王五

在岗人员：李某文

存在问题（共计4个）：

（一）安全生产方面（3个问题）

1. 吊装作业未办理票据，现场无监护人。

2. 应急值守人员不清楚自身的各位职责。

3. 应急预案无审核人签字。

（二）车辆管理方面（1个问题）

4.大型车辆驾驶员无体检报告。

整改期限:5天，

29、自检自查单位：朋才玉工贸有限公司 中小型企业

检查时间：5月2号

检查人:张三、李四、王五

在岗人员：单某

存在问题（共计5个）：

（一）安全生产方面（2个问题）

1. 应急预案无签发时间，无演练记录，存在代签字现象。

2. 施工人员未按照安全标准施工作业，存在安全隐患。

3. 特种作业人员未取证。

（二）车辆管理方面（2个问题）

4. 1台车辆未年检，司机未进行出车前检查。

5. 1具车载灭火器损坏。

整改期限:立查立改。

希望通过vba提取信息的要点：按照1.大型企业安全生产方面

2.大型企业压力（消防）器材管理方面

3.大型企业车辆管理方面

4.中小型企业安全生产方面

5.中小型企业压力（消防）器材管理方面

6.中小型企业车辆管理方面

这6大类从原文档里提取具体企业名称和对应的具体某方面问题复制到剪贴板或者复制到新打开一个空文档里，以便按照问题项汇总信息。比如对于大型企业“安全生产”方面的信息，那么需要从原文档提取复制的内容如下：（企业名称用加粗字体，问题项的序号不用复制）

大型企业安全生产方面：

北京新思路运输有限公司二分公司

配电箱周围堆放可燃杂物。

私自接线，电源线头裸露，无防护措施。

存在超负荷用电且无漏电保护装置。

前期自检自查发现的问题未及时整改。

七彩会心钢材卷制厂

大厅内1具灭火器未定期检查。

中船建设公司

特种设备未定期检验。

中兴自来水厂

未建立自检自查制度。

部分防护装备过期。

对于中小型企业“车辆管理方面”的问题”那么需要提取的内容希望如下所示:

中小型企业车辆管理方面：

新家园工程有限公司

1台特种车辆未年检。

达伽马运输公司

大型车辆驾驶员无体检报告。

朋才玉工贸有限公司

1台车辆未年检，司机未进行出车前检查。

1具车载灭火器损坏。

同样的对于：

大型企业压力（消防）器材管理方面

新番齐瑞达特种装备制造有限责任公司公司

院内1具灭火器压力不足。

中船建设公司

2具灭火器压力不符合要求。

压力容器台账填写不规范。

因上传字数限制，部分企业信息删去了，详细内容请见附件。

cuanju · 发表于 2020-6-11 10:46

可以通过运行代码，将文中所有的“检查时间……在岗人员”等条目删除，剩下的就一目了然了，
=============================
Sub dm1()
Rem 删除指定条目
With ActiveDocument.Content.Find
      .MatchWildcards = True
      .Text = "检查时间*在岗人员"
      Do While .Execute
         With .Parent
            .Expand (wdParagraph) '扩展至整段
            .Delete
            '.Font.Color = vbBlue
            .Start = .End
         End With
      Loop
End With
ActiveDocument.Content.Find.Execute FindText:="自检自查单位：", ReplaceWith:="", Replace:=wdReplaceAll, MatchWildcards:=True
ActiveDocument.Content.Find.Execute FindText:="整改期限[：:]*^13", ReplaceWith:="", Replace:=wdReplaceAll, MatchWildcards:=True
ActiveDocument.Content.Find.Execute FindText:="[ ]{1,}[大中小]{1,}型企业[ ]{1,}", ReplaceWith:="", Replace:=wdReplaceAll, MatchWildcards:=True
End Sub

wt29106 · 发表于 2020-6-11 12:41

cuanju 发表于 2020-6-11 10:46
可以通过运行代码，将文中所有的“检查时间……在岗人员”等条目删除，剩下的就一目了然了，
============ ...

感谢cuanju老师的帮助，这样做的确更简明了，不过因为需要写关于检查情况的材料就要按类别把原文档的信息提取出来，类似文档很多，一个一个手动粘贴工作量很大，就想试试用vba的方法，不知能否解决

413191246se · 发表于 2020-6-14 01:04

本帖最后由 413191246se 于 2020-6-14 13:10 编辑

Sub test()
Dim doc As Document, newdoc As Document, i As Paragraph, j&, k&, v$, s$, t$, m$, n$, p&, q$
Set doc = ActiveDocument
Set newdoc = Documents.Add
With doc
.Activate
With .Content
.InsertAfter Text:=vbCr & "99、自检自查单位："
With .Find
.Execute "　", , , 1, , , , , , " ", 2
.Execute "^t", , , 1, , , , , , " ", 2
.Execute "^s", , , 1, , , , , , " ", 2
End With
End With
End With
For p = 1 To 2
If p = 1 Then
q = "大型"
ElseIf p = 2 Then
q = "中小型"
End If
For k = 1 To 3
If k = 1 Then
v = "安全生产方面"
ElseIf k = 2 Then
v = "压力（消防）器材管理方面"
ElseIf k = 3 Then
v = "车辆管理方面"
End If
n = ""
newdoc.Content.InsertAfter Text:="█ " & q & "企业 - " & v & "：" & vbCr
For Each i In doc.Paragraphs
With i.Range
If .Text Like "*自检自查单位*" & q & "企业*" Then
.Characters(InStr(.Text, "：")).Select
With Selection
.MoveEndUntil cset:=" "
.MoveStart
s = .Text
End With
.Select
With Selection
Do
.MoveEnd
Loop Until .Text Like "*自检自查单位"
.MoveEnd 4, -2
If .Text Like "*" & v & "*" Then
.Paragraphs(1).Range.Select
Do
.MoveEnd
Loop Until .Text Like "*" & v
.Paragraphs.Last.Range.Select
Else
GoTo sk
End If
.Characters(InStr(.Text, "个") - 1).Select
j = .Text
If .Previous Like "[0-9]" Then .MoveStart 1, -1
.Paragraphs(1).Range.Select
.MoveEnd 4, j
.MoveStart 4, 1
t = "★ " & s & vbCr & .Text & vbCr
n = n & t
End With
End If
End With
sk:
Next
newdoc.Content.InsertAfter Text:=vbCr & n
Next k
Next p
doc.Close SaveChanges:=wdDoNotSaveChanges
'''
With ActiveDocument
.ConvertNumbersToText
With .Content.Font
.NameFarEast = "宋体"
.NameAscii = "Times New Roman"
.Size = 10.5
.ColorIndex = wdBlue
End With
For Each i In .Paragraphs
With i.Range
If .Text Like "█*" Then
With .Font
.NameFarEast = "华文中宋"
.Size = 16
.Bold = True
.ColorIndex = wdRed
End With
ElseIf .Text Like "★*" Then
With .Font
.NameFarEast = "黑体"
.Bold = True
.ColorIndex = wdPink
End With
End If
End With
Next
With .Content.Find
.Execute "([、.．）])([ 　^s^t]{1,})", , , 1, , , , , , "\1", 2
.Execute "(^13)([0-9]{1,}.)", , , 1, , , , , , "\1", 2
End With
For Each i In .Paragraphs
With i.Range
If Not (.Text Like "█*" Or .Text Like "★*" Or .Text = vbCr) Then .InsertBefore Text:="☆ "
End With
Next
' .Content.Font.ColorIndex = wdAuto '自动色（如果不想要彩色文档，只须删除本语句前的小撇儿'即可）
End With
MsgBox "处理完毕！文档尚未保存！", 0 + 48
End Sub

复制代码

413191246se · 发表于 2020-6-14 23:11

顶一下。。。

wt29106 · 发表于 2020-6-15 17:42

413191246se 发表于 2020-6-14 01:04

非常非常感谢413191246老师的帮助，代码很强大，几乎完美，就是运行到最后一个类别“█ 中小型企业 - 车辆管理方面：”时没有单位信息了，提示是“集合所要求的成员不存在”，运行的版本是word2007版，不知道是哪里的问题

413191246se · 发表于 2020-6-15 23:18

楼主，我的代码已经完美！在 Word2019 中测试 OK！没有更改的了！
请你重新检查一下，你用的附件，是否你所提供的附件？（另外，附件中的红字说明部分要删除后保存再测试！）

wt29106 · 发表于 2020-6-16 12:46

413191246se 发表于 2020-6-15 23:18
楼主，我的代码已经完美！在 Word2019 中测试 OK！没有更改的了！
请你重新检查一下，你用的附件，是否你 ...

把红色字体删除后，重新测试完全达到要求，再次感谢413191246老师的帮助!!!

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

[求助] 从原文档里复制企业名称和具体问题项粘贴到新的空白文档里或者复制到剪贴板

评分

评分

评分