VBA：从一个word文档复制文本到另一个word文档

DebugUsery
2,146 阅读5分钟

本教程解释了如何用VBA从一个word文档中复制内容并粘贴到另一个word文档中。当你需要每天或每周创建一个新的MS word文档，作为主文档的一个子集时，这是利益相关者最常见的要求之一。如果你手动操作，这是一个繁琐的任务，而且出错的几率也很大。在自动化的世界里，我们的目标是尽可能地将我们的重复性任务自动化。作为一个请求，它看起来很容易，但它有点复杂，因为你需要从Excel处理MS word，并需要通过VBA给系统指示你想要实现的变化和互动性。

复制所有标题到另一个文档

下面的程序复制每一个格式为Heading 1 的文本并粘贴到一个新的word文档。你需要对红色标示的几行代码进行修改。

Sub CopyfromWord()
    
   ' Objects
    Dim wrdApp, objWord As Object
    Dim wrdDoc, newwrdDoc As Object
    Dim myPath As String, myPath1 As String
    Dim numberStart As Long
    Dim Rng, srchRng As Word.Range

   ' Close MS Word if it's already opened
    On Error Resume Next
     Set objWord = GetObject(, "Word.Application")
     If Not objWord Is Nothing Then
            objWord.Quit SaveChanges:=0
            Set objWord = Nothing
    End If
    
    'Open MS Word
    Set wrdApp = CreateObject("Word.Application")
        wrdApp.Visible = True
        
    ' Folder Location

如何使用上述程序

  1. 打开Excel工作簿
  2. 按ALT+F11快捷键，打开Visual Basic编辑器(VBE)
  3. 要插入一个模块，进入插入>模块
  4. 粘贴下面完整的VBA脚本
  5. 在myPath 变量中指定文件夹的路径。这是你输入的word文档文件所存放的文件夹位置。请确保在最后提到反斜杠。
    myPath = "C:\Users\DELL\Documents\Test\"
  6. 指定你输入的MS Word文件的文件名
    Set wrdDoc = wrdApp.Documents.Open(myPath & "PD Calibration.docx")
  7. 你希望在你的输出文件中使用的文件名。新的Word文档将以这个名称保存。
    myPath1 = myPath & "\newdoc1.docx"
  8. 在搜索框中输入你想搜索的单词。如果你只想通过样式搜索，请保持空白。 FindWord = "".
  9. 在mystyle = "Heading 1" ，指定你的word文档的具体样式。

这个程序是如何工作的

在本节中，我们将代码分解成多个片段，使你了解它是如何工作的。

1.首先我们要关闭已经打开的Word文档。这是为了避免Excel与Word之间的冲突。在代码的错误处理方面，这是一个有用的技术，因为有时代码可能会因为同时打开多个word文档而崩溃。

    On Error Resume Next
     Set objWord = GetObject(, "Word.Application")
     If Not objWord Is Nothing Then
            objWord.Quit SaveChanges:=0
            Set objWord = Nothing
    End If

2.在这部分代码中，我们将打开输入的Word文档。

    'Open MS Word
    Set wrdApp = CreateObject("Word.Application")
        wrdApp.Visible = True
        
    ' Folder Location
    myPath = "C:\Users\DELL\Documents\Test\"
    
    ' Input File
    Set wrdDoc = wrdApp.Documents.Open(myPath & "PD Calibration.docx")

3.3.在这里我们添加一个新的word文档，我们想在其中复制内容。

    Set newwrdDoc = wrdApp.Documents.Add
    myPath1 = myPath & "\newdoc1.docx"

4.用户需要提到他/她希望MS Word寻找的单词或样式。

    ' Text you want to search
    Dim FindWord As String
    Dim result As String
    FindWord = ""
    
    'Style
    mystyle = "Heading 1"

5.VBA代码的这一部分指的是MS Word中的查找功能。我们中的许多人通过点击CTRL + F快捷键来启用这一功能。While ... Wend 是Do While循环的一种替代方法。在这里，它被用来查找所有格式为 "标题1 "的单词。它是以迭代的方式找到所有搜索到的结果。在复制文本后，它将进入输出文档中最后填充的内容，然后粘贴之后的内容。

    With wrdDoc.ActiveWindow.Selection.Find
        .Text = FindWord
        .Replacement.Text = ""
        .Forward = True
        .Wrap = 1
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        If mystyle <> "" Then
        .Style = mystyle
        End If
    End With
    
    ' Execute find method selects the found text if found
    wrdDoc.ActiveWindow.Selection.Find.Execute
    
    While wrdDoc.ActiveWindow.Selection.Find.Found
    wrdDoc.ActiveWindow.Selection.Copy
    
    'Activate the new document
    newwrdDoc.Activate
    
    'New Word Doc
    Set Rng = newwrdDoc.Content
    Rng.Collapse Direction:=wdCollapseEnd
    Rng.Paste
   
   'Word Document
   wrdDoc.Activate
   wrdDoc.ActiveWindow.Selection.Find.Execute
   
   Wend

6.最后一件极其重要的事情是保存文件并关闭MS Word应用程序。我们在关闭输入文件时没有保存任何修改，但输出文件却保存了我们所做的所有修改。

    'Close and don't save application
    wrdDoc.Close SaveChanges:=False
    
    'Save As New Word Document
    newwrdDoc.SaveAs myPath1
    newwrdDoc.Close SaveChanges:=False
    
    'Close all word documents
    wrdApp.Quit SaveChanges:=0

从一个Word文档中复制文本到已经创建的Word文档中

假设你不想创建一个新的Word文档。相反，你希望把它保存在你现有的word文档中。假设输出文件的名称是newdoc1.docx。

用下面的代码替换这行代码Set newwrdDoc = wrdApp.Documents.Add 。

    Set newwrdDoc = wrdApp.Documents.Open(myPath & "newdoc1.docx")

如果你希望用新的名字保存文件，你可以在这行代码中进行修改。

myPath1 = myPath & "\newdoc1_updated.docx"

找到特定的文本，然后复制接下来的3个单词或字符

指定你想在FindWord = "Text you wish to search" 中找到的单词，并使样式空白。
mystyle = ""

用下面的代码替换这行代码wrdDoc.ActiveWindow.Selection.Copy 。

下3个字

    lngStart = wrdDoc.ActiveWindow.Selection.End
    wrdDoc.ActiveWindow.Selection.MoveRight Unit:=wdWord, Count:=3, Extend:=wdExtend
    wrdDoc.ActiveWindow.Selection.Collapse Direction:=wdCollapseEnd
    lngEnd = wrdDoc.ActiveWindow.Selection.Start
    wrdDoc.Range(lngStart, lngEnd).Copy
    wrdDoc.ActiveWindow.Selection.EndOf

接下来的3个字符

   lngStart = wrdDoc.ActiveWindow.Selection.End
    wrdDoc.Range(lngStart, lngStart + 3).Copy

如果有一些空格，你可能会发现代码只提取了2个字符（或词），而不是3个，所以你可以在上面的代码中把数字从3增加到4

复制两个词之间的文本

假设你希望提取两个词（或标题）之间的所有文本。在下面的代码中，你可以在FindWord1 和FindWord2 变量中指定这些词。

Sub CopyBetweenTexts()
    
   ' Objects
    Dim wrdApp, objWord As Object
    Dim wrdDoc, newwrdDoc As Object
    Dim myPath As String, myPath1 As String
    Dim numberStart As Long
    Dim Rng, srchRng As Word.Range

   ' Close MS Word if it's already opened
    On Error Resume Next
     Set objWord = GetObject(, "Word.Application")
     If Not objWord Is Nothing Then
            objWord.Quit SaveChanges:=0
            Set objWord = Nothing
    End If
    
    'Open MS Word
    Set wrdApp = CreateObject("Word.Application")
        wrdApp.Visible = True
        
    ' Folder Location
    myPath = "C:\Users\DELL\Documents\Test\"
    
    ' Input File
    Set wrdDoc = wrdApp.Documents.Open(myPath & "PD Calibration.docx")
    
    ' Output File
    Set newwrdDoc = wrdApp.Documents.Add
    myPath1 = myPath & "\newdoc1.docx"

    ' Text you want to search
    Dim FindWord1, FindWord2 As String
    Dim result As String

寻找多个不同的文本并在循环中复制

如果你希望以迭代的方式提取几个文本之间的内容，然后在另一个word文档中逐一复制它们。
这里我们假设文本从B3单元格开始存储在B列。请看下面的图片。

Sub CopyBetweenTexts2()
    
   ' Objects
    Dim wrdApp, objWord As Object
    Dim wrdDoc, newwrdDoc As Object
    Dim myPath As String, myPath1 As String
    Dim numberStart As Long
    Dim Rng, srchRng As Word.Range

   ' Close MS Word if it's already opened
    On Error Resume Next
     Set objWord = GetObject(, "Word.Application")
     If Not objWord Is Nothing Then
            objWord.Quit SaveChanges:=0
            Set objWord = Nothing
    End If
    
    'Open MS Word
    Set wrdApp = CreateObject("Word.Application")
        wrdApp.Visible = True
        
    ' Folder Location
    myPath = "C:\Users\DELL\Documents\Test\"
    
    ' Input File
    Set wrdDoc = wrdApp.Documents.Open(myPath & "PD Calibration.docx")
    
    ' Output File
    Set newwrdDoc = wrdApp.Documents.Add
    myPath1 = myPath & "\newdoc1.docx"

    ' Text you want to search
    Dim FindWord1, FindWord2 As String
    Dim result As String
    
    ' Find last used cell in column B
    Dim last As Double
    With ActiveSheet
        last = .Cells(.Rows.Count, "B").End(xlUp).Row
    End With

    ' Loop through column B
    j = last - 2
    For i = 1 To j

查找文本和全部替换

假设你想找到一个特定的文本，然后用一些文本替换它。如果一个文本出现的次数超过1次，就应该进行处理。换句话说，应该启用全部替换功能。在这里，我们从输入的word文档中复制后在输出的文档中进行替换。在 Next i 行后添加以下代码。在**.Text =和.Replacement.Text =**中指定文本。

   'Replace All Name
    newwrdDoc.Activate
    With newwrdDoc.ActiveWindow.Selection.Find
        .Text = "Text 1"
        .Replacement.Text = "Text 2"
        .Forward = True
        .Wrap = 1
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    newwrdDoc.ActiveWindow.Selection.Find.Execute Replace:=wdReplaceAll
avatar
文章
阅读
粉丝