Question

我有几个word文件。他们就是这样建造的文字
文字
文字
姓名：Mick
日期：1-1-1
文字
文字
货号：Item11材质：金
文字
文字

我正在构建一个可以打开word文件的宏，将名称放在Cell A1中并将项目放在Cell A2中。我在互联网上找到了一个代码并稍微调整了一下。以下代码从单词doc的开头进行选择，直到找到单词并在给定单元格中复制该选择。

我希望有人可以告诉我如何调整这一点，以便选择在所需值停止之后开始

以下代码适用于项目：

Dim wdApp As Object, wdDoc As Object, wdRng As Object

Set wdApp = CreateObject("Word.Application")
With wdApp
  .Visible = True
    Set wdDoc = .Documents.Open("path", False, True, False)
    With wdDoc
      Set wdRng = .Range(0, 0)
      With .Range
        With .Find
          .Text = "material"
          .Forward = True
          .MatchWholeWord = True
          .MatchCase = True
          .Execute
        End With
        If .Find.found = True Then
          wdRng.End = .Duplicate.Start
          Sheets("sheet1").Range("A2").value = wdRng
        End If
  End With
      .Close False
    End With
  .Quit
End With
Set wdRng = Nothing: Set wdDoc = Nothing: Set wdApp = Nothing

有人有什么建议吗？

Answer 1

请尝试以下步骤。它将打开指定的Word文档，通过正则表达式解析所需的值，将这些值放入单元格A1和A2，然后关闭Word文档。

调用该过程时，请指定Word文档的完整路径和文件名。
例如：SetNameAndItem "C:\Temp\Doc1.docx"

Public Sub SetNameAndItem(strPath As String)
    Dim wdApp As Object: Set wdApp = CreateObject("Word.Application")
    Dim wdDoc As Object: Set wdDoc = wdApp.Documents.Open(strPath, False, True, False)
    Dim objRegEx As Object: Set objRegEx = CreateObject("VBScript.RegExp")
    Dim objMatches As Object

    On Error GoTo ProcError

    With objRegEx
        .Global = False
        .MultiLine = True
        .IgnoreCase = False
        .Pattern = "^Name:\s(.*?)$"
    End With

    Set objMatches = objRegEx.Execute(wdDoc.Content)
    If objMatches.Count = 0 Then
        Debug.Print "Name: No match."
    Else
        Range("A1").Value = objMatches(0).SubMatches(0)
    End If

    objRegEx.Pattern = "^Item:\s(.*?)\smaterial"
    Set objMatches = objRegEx.Execute(wdDoc.Content)
    If objMatches.Count = 0 Then
        Debug.Print "Item: No match."
    Else
        Range("A2").Value = objMatches(0).SubMatches(0)
    End If

ProcExit:
    On Error Resume Next
    wdDoc.Close False
    wdApp.Quit
    Set objMatches = Nothing
    Set objRegEx = Nothing
    Set wdDoc = Nothing
    Set wdApp = Nothing
    Exit Sub
ProcError:
  MsgBox "Error# " & Err.Number & vbCrLf & Err.Description, , "SetNameAndItem"
  Resume ProcExit
End Sub

结果：

注意：请确保Word文档中的换行符包含正常的回车符/换行符字符组合（按 Enter 键的结果）。当我从您的问题中复制/粘贴文本时，文档看起来像预期的那样，但看似换行的实际上是Vertical Tab字符，因此正则表达式不起作用。我不是说你有任何错误，它可能是粘贴网页文字的工件。只是需要注意的事情。

UPDATE：

如果上面代码中的正则表达式不起作用，那么可能它毕竟不是复制/粘贴问题，并且您的文档中确实有垂直制表符。如果是这种情况，请尝试按如下方式修改Excel VBA代码中的SetNameAndItem过程。

替换这两行（使用^和$分别代表行的起点和终点）：

.Pattern = "^Name:\s(.*?)$"

objRegEx.Pattern = "^Item:\s(.*?)\smaterial"

使用这两行（使用\v表示垂直制表符）：

.Pattern = "\vName:\s(.*?)\v"

objRegEx.Pattern = "\vItem:\s(.*?)\smaterial"

Answer 2

以下是您的问题的可能解决方案：

使用此功能读取word文件：

Option Explicit

Public Function f_my_story() as string

    Dim wdApp       As Object
    Dim wdDoc       As Object

    Set wdApp = CreateObject("Word.Application")

    With wdApp

        .Visible = True
        Set wdDoc = .Documents.Open("C:\Users\v\Desktop\text.docx", False, True, False)
        f_my_story = wdDoc.Range(0, wdDoc.Range.End)
        wdDoc.Close False
        .Quit

    End With

End Function

读完文件后，会得到一个字符串。现在你需要一个宏，它用空格分隔字符串，然后返回值，这些值在你要查找的值之后。
您可以在任何地方写下这些值。

从excel打开word doc并将所需信息复制到excel文件

2 个答案: