![](/img/trans.png)
[英]VBA copy page range from word document, and paste values matching format
[英]How to paste values on every page of word document from Excel VBA?
我在 Excel 中有一长串单词路径以及开始和结束标签。 我需要使用 Excel 中指定的路径打开 word 文档,并在每个页面的开头粘贴一个开始标记,并在每个页面的末尾粘贴一个结束标记。 每个文件都有三页。 我正在努力使用 Excel VBA 并且似乎无法让它工作。 谁能帮我?
我需要我的代码来遍历列表,打开文件,复制每页开头的 starttag 和每页结尾的 end 标记,保存并关闭文档并继续下一个文档。
到现在为止,我设法打开了我的 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 包含所有第二页等。我尝试查找/选择代码,但它选择了第一页和最后一页,而不是第一页。
这是我目前一一打开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
试试这个版本,我建议你先尝试一小批文档,因为粘贴标签后文档会立即保存。 (如果您不想保存和/或关闭,请注释掉这些行):
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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.