Excel提取Word表格内容。小白练手

ht1480 · 发表于 2022-10-19 15:56:24

<div class="blockcode"><blockquote>'wdCell 12 单元格。
'wdCharacter 1 字符。
'wdCharacterFormatting 13 字符格式。
'wdColumn 9 列。
'wdItem 16 所选项。
'wdLine 5 一个线段。
'wdParagraph 4 段落。
'wdParagraphFormatting 14 段落格式。
'wdRow 10 行。
'wdScreen 7 屏幕尺寸。
'wdSection 8 一节。
'wdSentence 3 句子。
'wdStory 6 部分。
'wdTable 15 一个表格。
'wdWindow 11 窗口。
'wdWord 2 字。
'Expand 扩展
Sub 提取报告工作量稳定版()
Dim a, myrang
'搜索工作量表格关键字
str1 = "建筑物数量"
Set wdapp = CreateObject("word.application")
'Word窗口显示开
wdapp.Visible = True
'选择文件夹
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then mypath = .SelectedItems(1) Else Exit Sub '打开目标文件夹
End With
'文件地址加“\”
mypath = mypath & ""
'从第几行开始写入
r = 2
'Dir文档名称
myfile = Dir(mypath)
'检查后缀打开文档
Do While myfile <> ""
If Right(UCase(myfile), 4) = ".DOC" Or Right(UCase(myfile), 4) = "DOCX" Then '检查扩展名是否为Word文件
Set wddoc = wdapp.Documents.Open(mypath & myfile) '打开文件
'写入文档名称
Cells(r, 1) = myfile
'激活文档
Set myrange = wdapp.ActiveDocument.Content
'查找str1
With myrange.Find
.Text = str1
.Forward = True
.Execute
If .Found = True Then
myrange.Select
'wdapp.Selection.Move unit:=10, Count:=1
'wdapp.Selection.Expand unit:=10
'MsgBox (wdapp.Selection.Text)
'MsgBox (wdapp.Selection.tables(1).Columns.Count)
For i = 1 To wdapp.Selection.tables(1).Columns.Count
Cells(r, i + 1).Value = wdapp.Selection.tables(1).Cell(2, i).Range.Text 'Word表格的内容通过该方法获取
Cells(r, i + 1).Value = Left(Cells(r, i + 1).Value, Len(Cells(r, i + 1).Value) - 1) '去除获取内容末尾的黑点(左长度减1来实现)
Next i
Cells(r, i + 1).Value = wdapp.ActiveDocument.Paragraphs(1).Range.Text
Cells(r, i + 1).Value = Left(Cells(r, i + 1).Value, Len(Cells(r, i + 1).Value) - 1)
'Cells(CellsR, CellsC).Value = wdapp.Selection.tables.Count.Cell(1, 1).Range.Text 'Word表格的内容通过该方法获取
'Cells(CellsR, CellsC).Value = Left(Cells(CellsR, CellsC).Value, Len(Cells(CellsR, CellsC).Value) - 1) '去除获取内容末尾的黑点
'Cells(r, 2).Value = wdapp.Selection.Text
'Cells(r, 3) = Selection.Text
'For Each i In ActiveDocument.Paragraphs
Else
Cells(r, 2) = "报告内没有此字符"
End If
End With
r = r + 1
wddoc.Close
End If
myfile = Dir()
Loop
wdapp.Quit
MsgBox ("提取出的数据不能进行统计计算" & Chr(10) & "如需统计和计算请另行处理" & Chr(10) & "（可以粘贴到Word再粘贴回Excel）")
End Sub

<div class="blockcode"><blockquote>'wdCell  12  单元格。 
'wdCharacter 1   字符。 
'wdCharacterFormatting   13  字符格式。 
'wdColumn    9   列。 
'wdItem  16  所选项。 
'wdLine  5   一个线段。 
'wdParagraph 4   段落。 
'wdParagraphFormatting   14  段落格式。 
'wdRow   10  行。 
'wdScreen    7   屏幕尺寸。 
'wdSection   8   一节。 
'wdSentence  3   句子。 
'wdStory 6   部分。 
'wdTable 15  一个表格。 
'wdWindow    11  窗口。 
'wdWord  2   字。 
'Expand 扩展 
Sub 提取报告工作量稳定版() 
Dim a, myrang 
'搜索工作量表格关键字 
str1 = "建筑物数量" 
Set wdapp = CreateObject("word.application") 
'Word窗口显示开 
wdapp.Visible = True 
'选择文件夹 
With Application.FileDialog(msoFileDialogFolderPicker) 
        If .Show Then mypath = .SelectedItems(1) Else Exit Sub '打开目标文件夹 
End With 
'文件地址加“\” 
    mypath = mypath & "" 
'从第几行开始写入 
    r = 2 
'Dir文档名称 
    myfile = Dir(mypath) 
'检查后缀打开文档 
Do While myfile <> "" 
  If Right(UCase(myfile), 4) = ".DOC" Or Right(UCase(myfile), 4) = "DOCX" Then '检查扩展名是否为Word文件 
  Set wddoc = wdapp.Documents.Open(mypath & myfile) '打开文件 
'写入文档名称 
Cells(r, 1) = myfile 
'激活文档 
Set myrange = wdapp.ActiveDocument.Content 
'查找str1 
With myrange.Find 
 .Text = str1 
 .Forward = True 
 .Execute 
 If .Found = True Then 
 myrange.Select 
 'wdapp.Selection.Move unit:=10, Count:=1 
 'wdapp.Selection.Expand unit:=10 
 'MsgBox (wdapp.Selection.Text) 
'MsgBox (wdapp.Selection.tables(1).Columns.Count) 
For i = 1 To wdapp.Selection.tables(1).Columns.Count 
Cells(r, i + 1).Value = wdapp.Selection.tables(1).Cell(2, i).Range.Text 'Word表格的内容通过该方法获取 
Cells(r, i + 1).Value = Left(Cells(r, i + 1).Value, Len(Cells(r, i + 1).Value) - 1) '去除获取内容末尾的黑点(左长度减1来实现) 
 Next i 
Cells(r, i + 1).Value = wdapp.ActiveDocument.Paragraphs(1).Range.Text 
Cells(r, i + 1).Value = Left(Cells(r, i + 1).Value, Len(Cells(r, i + 1).Value) - 1) 
'Cells(CellsR, CellsC).Value = wdapp.Selection.tables.Count.Cell(1, 1).Range.Text 'Word表格的内容通过该方法获取 
'Cells(CellsR, CellsC).Value = Left(Cells(CellsR, CellsC).Value, Len(Cells(CellsR, CellsC).Value) - 1) '去除获取内容末尾的黑点 
'Cells(r, 2).Value = wdapp.Selection.Text 
 'Cells(r, 3) = Selection.Text 
'For Each i In ActiveDocument.Paragraphs 
Else 
Cells(r, 2) = "报告内没有此字符" 
 End If 
 End With 
 r = r + 1 
wddoc.Close 
End If 
myfile = Dir() 
Loop 
wdapp.Quit 
MsgBox ("提取出的数据不能进行统计计算" & Chr(10) & "如需统计和计算请另行处理" & Chr(10) & "（可以粘贴到Word再粘贴回Excel）") 
End Sub

本小白练手的习题，没看过vb.net，只能用VB宏运行速度慢，如有大神路过请指教优化。

664571221 · 发表于 2022-10-20 14:04:33

高手可以加我qq吗3298554767

ht1480 · 发表于 2022-10-20 18:27:49

我也是小白，只是在论坛学了点皮毛中的皮毛，提高了自己一点点的工作效率！

sunny_8848 · 发表于 2022-11-22 08:09:22

谢谢分享，下载尝试下

账号		自动登录	找回密码
密码			注册