如何在 Excel VBA 的 word 文档的每一页上粘贴值？
How to paste values on every page of word document from Excel VBA?
我在 Excel 中有一长串单词路径和开始和结束标签。我需要使用Excel中指定的路径打开word文档，并在每一页的开头粘贴一个开始标签，在每一页的结尾粘贴一个结束标签。每个文件都有三页。
我正在与 Excel VBA 作斗争，但似乎无法让它工作。谁能帮帮我？
我需要我的代码 运行 遍历列表，打开文件，复制每一页开头的开始标签和每一页结尾的结束标签，保存并关闭文档，然后继续下一个文档。
My excel structure
到目前为止，我成功打开了我的 excel 文档
Sub startword()
Set WordApp = CreateObject("word.Application")
Path = Range("B2").Value & Range("F5").Value
WordApp.Documents.Open Path
WordApp.Visible = True
End Sub
而且我能够将值复制并粘贴到新文档中。
Sub copyrange()
'declare word vars
Dim WrdApp As Word.Application
Dim WrdDoc As Word.Document
'Path = Range("B2").Value & Range("F5").Value
'declare excel vars
Dim ExcRng As Range
'create new word instance
Set WrdApp = New Word.Application
WrdApp.Visible = True
WrdApp.Activate
Set WrdDoc = WrdApp.Documents.Add
'create reference to range i want to copy
Set ExcRng = ActiveSheet.Range("B2:E6")
'copy the range and wait for a bit
ExcRng.Copy
Application.Wait Now() + #12:00:01 AM#
'paste the object in word
WrdDoc.Paragraphs(1).Range.PasteExcelTable LinkedToExcel:=True, WordFormatting:=True, RTF:=False
WrdApp.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext
WrdDoc.Paragraphs(1).Range.PasteSpecial Link:=True, DataType:=wdPasteOLEObject
'clear clipboard
Application.CutCopyMode = False
End Sub
范围完全随机
问题的第二部分
我正在为我的下一段代码而苦苦挣扎。我需要提取第一个开始和结束标记之间的内容（包括标记）并将它们移动到 doc 1，与第 2 页到 doc2，第 3 页到 doc 3 相同。所以我将得到三个文档。 doc1 包含我文档的所有第一页，doc 2 包含所有第二页等。我尝试 find/select 代码，但它选择了第一页和最后一页，而不是第一页。
这是我目前打开word文档的代码：
Sub SelectRangeBetween()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1") 'Change to the correct sheetname
Dim wrdApp As Word.Application
Dim WrdDoc As Word.Document
Set wrdApp = New Word.Application '
wrdApp.Visible = True 'set to false for higher speed
Const StarttagColumn = "C" 'Edit this for the column of the starttag.
Const EndtagColumn = "D" 'Edit this for the column of the endtag.
Const FilelocationColumn = "E" 'Edit this for the column of the Filelocation.
Const startRow As Long = 5 'This is the first row of tags and filenames
'Const endRow As Long = 140 'uncomment if you want a fixed amount of rows (for ranges with empty cells)
Dim endRow As Long 'comment out if const-endrow is used
endRow = ws.Range("B" & Rows.Count).End(xlUp).Row 'comment out if const-endrow is used
Dim i As Long
For i = startRow To endRow
Dim wrdPath As String
wrdPath = ws.Cells(i, FilelocationColumn).Value2 '
If wrdPath <> vbNullString Then '
If Dir(wrdPath) <> vbNullString Then '
Dim startTag As String '
Dim endTag As String '
startTag = ws.Cells(i, StarttagColumn).Value2 '
endTag = ws.Cells(i, EndtagColumn).Value2 '
Set WrdDoc = wrdApp.Documents.Open(wrdPath) '
With wrdApp
'.Documents.Add
' .Visible = True
' Types the text
'.Selection.HomeKey Unit:=wdStory
'.Selection.TypeText Text:="Hello and Goodbye"
' The Real script
'Dim StartWord As String, EndWord As String
'StartWord = "Hello"
'EndWord = "Goodbye"
With .ActiveDocument.Content.Duplicate
.Find.Execute FindText:=startTag & "*" & endTag, MatchWildcards:=False
.MoveStart wdCharacter, Len(StardWord)
.MoveEnd wdCharacter, -Len(EndWord)
.Select ' Or whatever you want to do
End With
End With
With WrdDoc
.Close
End With
End If
End If
Next i
End Sub
试试这个版本，我建议你先用小批量的文件试试，因为粘贴标签后文件会立即保存。 （如果不想保存，请注释掉这些行 and/or close）：
Option Explicit
Private Sub PasteTagsToDocument()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1") 'Change to the correct name
Const startRow As Long = 5
Dim endRow As Long
endRow = ws.Range("B" & Rows.Count).End(xlUp).Row
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Set wrdApp = New Word.Application
wrdApp.Visible = True
Dim i As Long
For i = startRow To endRow
Dim wrdPath As String
wrdPath = ws.Cells(i, 2).Value2
If wrdPath <> vbNullString Then
If Dir(wrdPath) <> vbNullString Then
Dim startTag As String
Dim endTag As String
startTag = ws.Cells(i, 3).Value2
endTag = ws.Cells(i, 4).Value2
Set wrdDoc = wrdApp.Documents.Open(wrdPath)
With wrdDoc
.Range(0, 0).InsertBefore startTag & vbNewLine
.GoTo(wdGoToPage, wdGoToAbsolute, 2).InsertBefore endTag & vbNewLine & startTag & vbNewLine
.GoTo(wdGoToPage, wdGoToAbsolute, 3).InsertBefore endTag & vbNewLine & startTag & vbNewLine
.Range.Paragraphs.Last.Range.InsertAfter vbNewLine & endTag
.Save 'Comment out if you do not want to save
.Close 'Comment out if you do not want to close the document
End With
Else
If MsgBox("File don't exist. " & vbNewLine & wrdPath & vbNewLine & "Click Ok to Continue or Cancel to stop the macro.", vbOKCancel) = vbCancel Then Exit For
End If
End If
Next i
Set ws = Nothing
Set wrdDoc = Nothing
wrdApp.Quit
Set wrdApp = Nothing
MsgBox "Complete!"
End Sub
我在 Excel 中有一长串单词路径和开始和结束标签。我需要使用Excel中指定的路径打开word文档，并在每一页的开头粘贴一个开始标签，在每一页的结尾粘贴一个结束标签。每个文件都有三页。 我正在与 Excel VBA 作斗争，但似乎无法让它工作。谁能帮帮我？
我需要我的代码 运行 遍历列表，打开文件，复制每一页开头的开始标签和每一页结尾的结束标签，保存并关闭文档，然后继续下一个文档。
My excel structure
到目前为止，我成功打开了我的 excel 文档
Sub startword()
Set WordApp = CreateObject("word.Application")
Path = Range("B2").Value & Range("F5").Value
WordApp.Documents.Open Path
WordApp.Visible = True
End Sub
而且我能够将值复制并粘贴到新文档中。
Sub copyrange()
'declare word vars
Dim WrdApp As Word.Application
Dim WrdDoc As Word.Document
'Path = Range("B2").Value & Range("F5").Value
'declare excel vars
Dim ExcRng As Range
'create new word instance
Set WrdApp = New Word.Application
WrdApp.Visible = True
WrdApp.Activate
Set WrdDoc = WrdApp.Documents.Add
'create reference to range i want to copy
Set ExcRng = ActiveSheet.Range("B2:E6")
'copy the range and wait for a bit
ExcRng.Copy
Application.Wait Now() + #12:00:01 AM#
'paste the object in word
WrdDoc.Paragraphs(1).Range.PasteExcelTable LinkedToExcel:=True, WordFormatting:=True, RTF:=False
WrdApp.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext
WrdDoc.Paragraphs(1).Range.PasteSpecial Link:=True, DataType:=wdPasteOLEObject
'clear clipboard
Application.CutCopyMode = False
End Sub
范围完全随机
问题的第二部分 我正在为我的下一段代码而苦苦挣扎。我需要提取第一个开始和结束标记之间的内容（包括标记）并将它们移动到 doc 1，与第 2 页到 doc2，第 3 页到 doc 3 相同。所以我将得到三个文档。 doc1 包含我文档的所有第一页，doc 2 包含所有第二页等。我尝试 find/select 代码，但它选择了第一页和最后一页，而不是第一页。
这是我目前打开word文档的代码：
Sub SelectRangeBetween()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1") 'Change to the correct sheetname
Dim wrdApp As Word.Application
Dim WrdDoc As Word.Document
Set wrdApp = New Word.Application '
wrdApp.Visible = True 'set to false for higher speed
Const StarttagColumn = "C" 'Edit this for the column of the starttag.
Const EndtagColumn = "D" 'Edit this for the column of the endtag.
Const FilelocationColumn = "E" 'Edit this for the column of the Filelocation.
Const startRow As Long = 5 'This is the first row of tags and filenames
'Const endRow As Long = 140 'uncomment if you want a fixed amount of rows (for ranges with empty cells)
Dim endRow As Long 'comment out if const-endrow is used
endRow = ws.Range("B" & Rows.Count).End(xlUp).Row 'comment out if const-endrow is used
Dim i As Long
For i = startRow To endRow
Dim wrdPath As String
wrdPath = ws.Cells(i, FilelocationColumn).Value2 '
If wrdPath <> vbNullString Then '
If Dir(wrdPath) <> vbNullString Then '
Dim startTag As String '
Dim endTag As String '
startTag = ws.Cells(i, StarttagColumn).Value2 '
endTag = ws.Cells(i, EndtagColumn).Value2 '
Set WrdDoc = wrdApp.Documents.Open(wrdPath) '
With wrdApp
'.Documents.Add
' .Visible = True
' Types the text
'.Selection.HomeKey Unit:=wdStory
'.Selection.TypeText Text:="Hello and Goodbye"
' The Real script
'Dim StartWord As String, EndWord As String
'StartWord = "Hello"
'EndWord = "Goodbye"
With .ActiveDocument.Content.Duplicate
.Find.Execute FindText:=startTag & "*" & endTag, MatchWildcards:=False
.MoveStart wdCharacter, Len(StardWord)
.MoveEnd wdCharacter, -Len(EndWord)
.Select ' Or whatever you want to do
End With
End With
With WrdDoc
.Close
End With
End If
End If
Next i
End Sub
试试这个版本，我建议你先用小批量的文件试试，因为粘贴标签后文件会立即保存。 （如果不想保存，请注释掉这些行 and/or close）：
Option Explicit
Private Sub PasteTagsToDocument()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1") 'Change to the correct name
Const startRow As Long = 5
Dim endRow As Long
endRow = ws.Range("B" & Rows.Count).End(xlUp).Row
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Set wrdApp = New Word.Application
wrdApp.Visible = True
Dim i As Long
For i = startRow To endRow
Dim wrdPath As String
wrdPath = ws.Cells(i, 2).Value2
If wrdPath <> vbNullString Then
If Dir(wrdPath) <> vbNullString Then
Dim startTag As String
Dim endTag As String
startTag = ws.Cells(i, 3).Value2
endTag = ws.Cells(i, 4).Value2
Set wrdDoc = wrdApp.Documents.Open(wrdPath)
With wrdDoc
.Range(0, 0).InsertBefore startTag & vbNewLine
.GoTo(wdGoToPage, wdGoToAbsolute, 2).InsertBefore endTag & vbNewLine & startTag & vbNewLine
.GoTo(wdGoToPage, wdGoToAbsolute, 3).InsertBefore endTag & vbNewLine & startTag & vbNewLine
.Range.Paragraphs.Last.Range.InsertAfter vbNewLine & endTag
.Save 'Comment out if you do not want to save
.Close 'Comment out if you do not want to close the document
End With
Else
If MsgBox("File don't exist. " & vbNewLine & wrdPath & vbNewLine & "Click Ok to Continue or Cancel to stop the macro.", vbOKCancel) = vbCancel Then Exit For
End If
End If
Next i
Set ws = Nothing
Set wrdDoc = Nothing
wrdApp.Quit
Set wrdApp = Nothing
MsgBox "Complete!"
End Sub