如何用vba查找提取多个word文档中的关键字并创建超链接？

2024-05-26 22:10| 来源: 网络整理| 查看: 265

如何用vba查找提取多个word文档中的关键字并创建超链接？ 2018年5月31日作者：水星Excel 6,673 次浏览暂无评论

需要查找同一文件夹下的多个word文档，查看是否包含关键字，如果有，则把关键字所在的段落内容提取出来，并创建超链接，可以打开对应的word文档。

代码如下：

Dim oWord As Object Dim oDic As Object Sub QQ1722187970() Const wdParagraph = 4 Const wdExtend = 1 Set oWord = VBA.CreateObject("word.application") oWord.Visible = True '创建字典对象 Set oDic = CreateObject("Scripting.Dictionary") Dim sPath As String '获取文件或者文件夹的路径 sPath = GetPath() If Len(sPath) Then Call EnuAllFiles(sPath) End If '查找到的段落内容 arrKeys = oDic.keys '查找到的段落所在文件路径 arrItems = oDic.iTems Set oDoc = oWord.Documents.Add With oDoc For i = 0 To UBound(arrKeys) oWord.Selection.TypeText Left(arrKeys(i), Len(arrKeys(i)) - 1) oWord.Selection.MoveUp wdParagraph, 1, wdExtend .Hyperlinks.Add oWord.Selection.Range, arrItems(i) oWord.Selection.TypeParagraph Next i ' For i = 1 To .Paragraphs.Count - 1 ' If Len(.Paragraphs(i).Range.Text) > 2 Then ' .Paragraphs(i).Range.Hyperlinks.Add .Paragraphs(i).Range, arrItems(k) ' k = k + 1 ' End If ' Next i End With Dim oWK As Worksheet Set oWK = Sheet5 With oWK .Range("a2:b65536").Clear For i = 2 To 2 + UBound(arrKeys) .Cells(i, "A") = arrKeys(i - 2) .Cells(i, "B") = arrItems(i - 2) .Hyperlinks.Add anchor:=.Cells(i, "B"), Address:=arrItems(i - 2) Next i .Columns.AutoFit End With Set oDic = Nothing '释放word应用程序对象 Set oWord = Nothing MsgBox "处理完成!!!" End Sub Function GetPath() As String '声明一个FileDialog对象变量 Dim oFD As FileDialog ' '创建一个选择文件对话框 ' Set oFD = Application.FileDialog(msoFileDialogFilePicker) '创建一个选择文件夹对话框 Set oFD = Application.FileDialog(msoFileDialogFolderPicker) '声明一个变量用来存储选择的文件名 Dim vrtSelectedItem As Variant With oFD '允许选择多个文件 .AllowMultiSelect = True '使用Show方法显示对话框，如果单击了确定按钮则返回-1。 If .Show = -1 Then '遍历所有选择的文件 For Each vrtSelectedItem In .SelectedItems '获取所有选择的文件的完整路径,用于各种操作 GetPath = vrtSelectedItem Next '如果单击了取消按钮则返回0 Else End If End With '释放对象变量 Set oFD = Nothing End Function Sub EnuAllFiles(ByVal sPath As String, Optional bEnuSub As Boolean = False) Dim oWK As Worksheet Set oWK = Excel.Worksheets("Sheet5") '要查找的关键字 With oWK sText = .Range("D1") End With '定义文件系统对象 Dim oFso As Object Set oFso = CreateObject("Scripting.FileSystemObject") '定义文件夹对象 Dim oFolder As Object Set oFolder = oFso.GetFolder(sPath) '定义文件对象 Dim oFile As Object '如果指定的文件夹含有文件 If oFolder.Files.Count Then For Each oFile In oFolder.Files With oFile '输出文件所在的盘符 Dim sDrive As String sDrive = .Drive '输出文件的类型 Dim sType As String sType = .Type '输出含后缀名的文件名称 Dim sName As String sName = .Name '输出含文件名的完整路径 Dim sFilePath As String sFilePath = .Path '如果文件是Word文件且不是隐藏文件 If sType Like "*ord*" And .Attributes 2 Then '以下是对每个文件进行处理的代码 '********************************* Debug.Print sFilePath '打开word文档 Set oDoc = oWord.Documents.Open(sFilePath) With oDoc Const wdReplaceAll = 2 Dim oRng Dim oRng1 Set oRng = oWord.Selection.Range '先判断是否有选中区域，没有选中则表示整个文档 If oRng.Start = oRng.End Then Set oRng = .Content End If '获取要执行操作的区域的起点和终点，用于查找替换时判断是否超出了选定区域 iStart = oRng.Start iEnd = oRng.End Debug.Print oRng.Text Set oRng1 = oRng With oRng1.Find .ClearFormatting .MatchWildcards = True .Text = sText '每执行一次查找，只要找到了结果，oRng对象会自动变成被找到的内容所在的区域 Do Until .Execute() = False Or oRng1.Start > iEnd Or oRng1.End < iStart sFindText = oRng1.Paragraphs(1).Range.Text With oDic If .exists(sFindText) Then Else .Add sFindText, sFilePath End If End With Loop End With '保存word文档 ' .Save '关闭word文档 .Close End With Else End If End With Next '如果指定的文件夹不含有文件 Else End If '如果要遍历子文件夹 If bEnuSub = True Then '定义子文件夹集合对象 Dim oSubFolders As Object Set oSubFolders = oFolder.SubFolders If oSubFolders.Count > 0 Then For Each oTempFolder In oSubFolders sTempPath = oTempFolder.Path Call EnuAllFiles(sTempPath, True) Next End If Set oSubFolders = Nothing End If Set oFile = Nothing Set oFolder = Nothing Set oFso = Nothing End Sub

其它相关文章推荐：如何用vba将同一文件下的所有03版本的word转换为最新版本？如何用vba把多个word文档的内容提取到excel中？如何用vba遍历word文档中的文本框？如何用vba获取相同单元格内容的联合单元格区域？如何用vba将试卷题目和选项分开？如何用vba给单元格的部分字符添加下划线？分类 : VBA , WORD VBA 标签 : 关键字查找

声明: 本站文章均属原创，未经作者同意必须保留此段声明，且在文章页面明显位置给出原文链接，否则视为侵权。如果想要每天都收到本站的技术文章推送，可以微信搜索公众号：水星Excel或者Excel_Office关注。其它事宜请加QQ：1722187970 或微信号：xycgenius 联系。

【本文地址】

公司简介

联系我们