将格式化的 table 从 doc1 复制到 doc2
Copy formatted table from doc1 to doc2
我有下面的函数，它从 Excel 电子表格中获取 table，创建多个数组，格式化 Word 表单，还修改 Word 文档模板以在来自已完成。
我想将 table 从第一个 Word 文档复制到第二个书签位置。我尝试了各种方法。我试过的最后一个应该是 select 第一个文件， select table 并将其复制到第二个。它成功完成，但它似乎从 Excel 文档中获取了一个单元格。
objWord.Documents("C:\temp\DOC1.docm").Activate
objDoc.Tables(2).Range.Select
Selection.Copy
objWord.Documents(""C:\temp\DOC2.docm").Activate
Set bkRange = objDoc2.Bookmarks(bkProductionHistory).Range
bkRange.Paste
Function FnOpenWordDoc(LastProdHist() As Variant, LastProdHistRow As Long, FileToSave As String) As Variant
Dim objWord
Dim objDoc
Dim objDoc2
Dim xPctComp As Long
Dim rRange As Word.Range 'MSword range for Boook mark
Dim bkRange As Word.Range
Dim tblNew As Table 'Table Production History
Dim BkProdHist As String 'Bookmark varialble
Dim x, y, a, b As Variant
BkProdHist = "BkProductionsHistory" 'Production History Bookmark - Containes the complete productiosn histor in the first workd doc.
'bookmarks for the email document
bkUserName = "bkUserName" 'bookmark Location for user name
BkVolume = "bkProductionVolume" 'Bookmark Location for volume information in email
bkProductionDownload = "bkProductionDownload" 'Bookmark location for Download Link in email
bkProductionHistory = "bkProductionHistory" 'Bookmark location for Table copied from first word document
bkProductionSearch = "bkProductionSearch" 'Bookmark location for Production Seach
bkArchivePassword = "bkArchivePassword" 'Bookmark Locaion for Archive password
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Open("C:\temp\DOC1.docm", ReadOnly:=True)
Set objDoc2 = objWord.Documents.Open(""C:\temp\DOC2.docm", ReadOnly:=True)
'objWord.Visible = False
objWord.Visible = True
objDoc.MailMerge.MainDocumentType = wdFormLetters
objDoc.MailMerge.OpenDataSource Name:= _
"C:\temp\DATA.XLSM", _
ConfirmConversions:=False, _
ReadOnly:=True, _
LinkToSource:=True, _
AddToRecentFiles:=False, _
PasswordDocument:="", _
PasswordTemplate:="", _
WritePasswordDocument:="", _
WritePasswordTemplate:="", _
Revert:=False, _
Format:=wdOpenFormatAuto, _
Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=C:\temp\DATA.XLSM;Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:", _
SQLStatement:="SELECT * FROM `ProductionRequest$`", SQLStatement1:="", _
SubType:=wdMergeSubTypeAccess
objDoc.MailMerge.DataSource.ActiveRecord = wdLastRecord
objDoc.MailMerge.ViewMailMergeFieldCodes = wdToggle
'objDoc.MailMerge.Execute
If Dir(FileToSave) <> vbNullString Then
Kill FileToSave
'MsgBox "Deleted the file"
End If
'***************Create New Table With Production History - this is t first word doc
**********************
LastProdHistRow = LastProdHistRow + 6 ' Adding additional rows to production history table
Set rRange = objDoc.Bookmarks(BkProdHist).Range
Set tblNew = objDoc.Tables.Add(Range:=rRange, NumRows:=LastProdHistRow, NumColumns:=10)
objDoc.Tables(2).Cell(3, 1).Range.Text = "Date"
objDoc.Tables(2).Cell(3, 2).Range.Text = "Volume"
objDoc.Tables(2).Cell(3, 3).Range.Text = "Begin Bates"
objDoc.Tables(2).Cell(3, 4).Range.Text = "End Bates"
objDoc.Tables(2).Cell(3, 5).Range.Text = "Documents"
objDoc.Tables(2).Cell(3, 6).Range.Text = "Redactions"
objDoc.Tables(2).Cell(3, 7).Range.Text = "Pages"
objDoc.Tables(2).Cell(3, 8).Range.Text = "Images"
objDoc.Tables(2).Cell(3, 9).Range.Text = "Natives"
objDoc.Tables(2).Cell(3, 10).Range.Text = "Slip-Sheets"
objDoc.Tables(2).Cell(LastProdHistRow + 6, 4).Range.Text = "Totals"
'************** End - Create Table with Production History
'Begin************** Copy Production History Array to Word Table *************************
'the loop only copies the first 10 columns of the array to the word table.
a = 4 ' The starting row of the table to begin copying data
For x = LBound(LastProdHist, 1) To UBound(LastProdHist, 1)
b = 1
For y = LBound(LastProdHist, 2) To UBound(LastProdHist, 2)
If y <= 9 Then
Debug.Print x, y, LastProdHist(x, y)
objDoc.Tables(2).Cell(a, b).Range.Text = LastProdHist(x, y)
b = b + 1
End If
Next y
a = a + 1
Next x
'End************** Produciton History Array to Word table ****************************
With objDoc.Tables(2)
.Range.Font.Size = 8
.Columns(2).Width = 40.5 'Date Column width
.Columns(3).Width = 81 'Begin Bates Column width
.Columns(4).Width = 81 'End Bates Colum width
.Columns(5).Width = 55 'Documents Column width
.Columns(6).Width = 55 'Redactions Column width
.Columns(7).Width = 37 'Pages Column width
.Columns(8).Width = 41 'Images Column width
.Columns(9).Width = 41 'Natives Column width
.Columns(10).Width = 62.5 'Slip-Sheet Column width
.Rows(LastProdHistRow).Range.Font.Bold = True
.Rows(3).Range.Font.Bold = True
.Rows(3).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Cell(LastProdHistRow, 5).Formula Formula:="=Sum(Above)"
.Cell(LastProdHistRow, 6).Formula Formula:="=Sum(Above)"
.Cell(LastProdHistRow, 7).Formula Formula:="=Sum(Above)"
.Cell(LastProdHistRow, 8).Formula Formula:="=Sum(Above)"
.Cell(LastProdHistRow, 9).Formula Formula:="=Sum(Above)"
.Cell(LastProdHistRow, 10).Formula Formula:="=Sum(Above)"
.Rows(LastProdHistRow).Borders(wdBorderTop).LineStyle = wdLineStyleSingle
.Rows(LastProdHistRow).Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
.Rows.SetLeftIndent LeftIndent:=-3.5, RulerStyle:=wdAdjustNone
End With
objDoc.Tables(2).Columns(1).Select
Set ObjSelection = objWord.Selection
ObjSelection.ParagraphFormat.Alignment = wdAlignParagraphRight
objDoc.Tables(2).Columns(2).Select
Set ObjSelection = objWord.Selection
ObjSelection.ParagraphFormat.Alignment = wdAlignParagraphCenter
objDoc.Tables(2).Columns(3).Select
Set ObjSelection = objWord.Selection
ObjSelection.ParagraphFormat.Alignment = wdAlignParagraphCenter
objDoc.Tables(2).Columns(4).Select
Set ObjSelection = objWord.Selection
ObjSelection.ParagraphFormat.Alignment = wdAlignParagraphCenter
objDoc.Tables(2).Columns(5).Select
Set ObjSelection = objWord.Selection
ObjSelection.ParagraphFormat.TabStops.Add Position:=InchesToPoints(0.4), Alignment:=wdAlignTabDecimal, Leader:=wdTabLeaderSpaces
objDoc.Tables(2).Columns(6).Select
Set ObjSelection = objWord.Selection
ObjSelection.ParagraphFormat.TabStops.Add Position:=InchesToPoints(0.4), Alignment:=wdAlignTabDecimal, Leader:=wdTabLeaderSpaces
objDoc.Tables(2).Columns(7).Select
Set ObjSelection = objWord.Selection
ObjSelection.ParagraphFormat.TabStops.Add Position:=InchesToPoints(0.5), Alignment:=wdAlignTabDecimal, Leader:=wdTabLeaderSpaces
objDoc.Tables(2).Columns(8).Select
Set ObjSelection = objWord.Selection
ObjSelection.ParagraphFormat.TabStops.Add Position:=InchesToPoints(0.5), Alignment:=wdAlignTabDecimal, Leader:=wdTabLeaderSpaces
objDoc.Tables(2).Columns(9).Select
Set ObjSelection = objWord.Selection
ObjSelection.ParagraphFormat.TabStops.Add Position:=InchesToPoints(0.25), Alignment:=wdAlignTabDecimal, Leader:=wdTabLeaderSpaces
objDoc.Tables(2).Columns(10).Select
Set ObjSelection = objWord.Selection
ObjSelection.ParagraphFormat.TabStops.Add Position:=InchesToPoints(0.4), Alignment:=wdAlignTabDecimal, Leader:=wdTabLeaderSpaces
With objDoc.Tables(2)
.Rows(2).Cells.Merge
.Cell(2, 1).Range.Text = "DOCUMENT PRODUCTION HISTORY"
.Cell(2, 1).Range.Style = ("Heading 1")
.Cell(LastProdHistRow, 4).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
.Rows(LastProdHistRow - 2).Shading.ForegroundPatternColor = wdColorAutomatic
.Rows(LastProdHistRow - 2).Shading.BackgroundPatternColor = -553582797
End With
'Begin************** Setting up Email to send to reqestor *************************
'****
'**** objDoc2 has been opend for the this reason
Set bkRange = objDoc2.Bookmarks(bkUserName).Range
bkRange.Text = LastProdHist(LastProdHistRow - 6, 13)
Set bkRange = objDoc2.Bookmarks(BkVolume).Range
bkRange.Text = LastProdHist(LastProdHistRow - 6, 1)
Set bkRange = objDoc2.Bookmarks(bkProductionSearch).Range
bkRange.Text = LastProdHist(LastProdHistRow - 6, 10)
Set bkRange = objDoc2.Bookmarks(bkArchivePassword).Range
bkRange.Text = LastProdHist(LastProdHistRow - 6, 11)
Set bkRange = objDoc2.Bookmarks(bkProductionDownload).Range
bkRange.Text = LastProdHist(LastProdHistRow - 6, 12)
objWord.Documents("C:\temp\DOC1.docm").Activate
objDoc.Tables(2).Range.Select
Selection.Copy
objWord.Documents(""C:\temp\DOC2.docm").Activate
Set bkRange = objDoc2.Bookmarks(bkProductionHistory).Range
bkRange.Paste
'End**************** Setting up Email to send to reqestor *************************
'Debug.Print FileToSave
objDoc.ExportAsFixedFormat OutputFileName:= _
"C:\Temp\" & FileToSave, ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=True, OptimizeFor:=wdExportOptimizeForPrint, Range:= _
wdExportAllDocument, From:=1, To:=1, Item:=wdExportDocumentContent, _
IncludeDocProps:=True, KeepIRM:=True, CreateBookmarks:= _
wdExportCreateNoBookmarks, DocStructureTags:=True, BitmapMissingFonts:= _
True, UseISO19005_1:=False
'ChangeFileOpenDirectory "C:\Temp\"
objDoc.MailMerge.DataSource.Close
'objDoc.Close SaveChanges:=wdDoNotSaveChanges
'objWord.Application.Quit
End Function
问题很简单——你没有资格Selection.Copy。应该是 objWord.Selection.Copy.
最好还是使用：
objDoc.Tables(2).Range.Copy
objDoc2.Bookmarks(bkProductionHistory).Range.Paste
您不需要激活任何一个文件。此外，复制所需的全部是：
objDoc2.Bookmarks(bkProductionHistory).Range.FormattedText = objDoc.Tables(2).Range.FormattedText
我有下面的函数，它从 Excel 电子表格中获取 table，创建多个数组，格式化 Word 表单，还修改 Word 文档模板以在来自已完成。
我想将 table 从第一个 Word 文档复制到第二个书签位置。我尝试了各种方法。我试过的最后一个应该是 select 第一个文件， select table 并将其复制到第二个。它成功完成，但它似乎从 Excel 文档中获取了一个单元格。
objWord.Documents("C:\temp\DOC1.docm").Activate
objDoc.Tables(2).Range.Select
Selection.Copy
objWord.Documents(""C:\temp\DOC2.docm").Activate
Set bkRange = objDoc2.Bookmarks(bkProductionHistory).Range
bkRange.Paste
Function FnOpenWordDoc(LastProdHist() As Variant, LastProdHistRow As Long, FileToSave As String) As Variant
Dim objWord
Dim objDoc
Dim objDoc2
Dim xPctComp As Long
Dim rRange As Word.Range 'MSword range for Boook mark
Dim bkRange As Word.Range
Dim tblNew As Table 'Table Production History
Dim BkProdHist As String 'Bookmark varialble
Dim x, y, a, b As Variant
BkProdHist = "BkProductionsHistory" 'Production History Bookmark - Containes the complete productiosn histor in the first workd doc.
'bookmarks for the email document
bkUserName = "bkUserName" 'bookmark Location for user name
BkVolume = "bkProductionVolume" 'Bookmark Location for volume information in email
bkProductionDownload = "bkProductionDownload" 'Bookmark location for Download Link in email
bkProductionHistory = "bkProductionHistory" 'Bookmark location for Table copied from first word document
bkProductionSearch = "bkProductionSearch" 'Bookmark location for Production Seach
bkArchivePassword = "bkArchivePassword" 'Bookmark Locaion for Archive password
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Open("C:\temp\DOC1.docm", ReadOnly:=True)
Set objDoc2 = objWord.Documents.Open(""C:\temp\DOC2.docm", ReadOnly:=True)
'objWord.Visible = False
objWord.Visible = True
objDoc.MailMerge.MainDocumentType = wdFormLetters
objDoc.MailMerge.OpenDataSource Name:= _
"C:\temp\DATA.XLSM", _
ConfirmConversions:=False, _
ReadOnly:=True, _
LinkToSource:=True, _
AddToRecentFiles:=False, _
PasswordDocument:="", _
PasswordTemplate:="", _
WritePasswordDocument:="", _
WritePasswordTemplate:="", _
Revert:=False, _
Format:=wdOpenFormatAuto, _
Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=C:\temp\DATA.XLSM;Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:", _
SQLStatement:="SELECT * FROM `ProductionRequest$`", SQLStatement1:="", _
SubType:=wdMergeSubTypeAccess
objDoc.MailMerge.DataSource.ActiveRecord = wdLastRecord
objDoc.MailMerge.ViewMailMergeFieldCodes = wdToggle
'objDoc.MailMerge.Execute
If Dir(FileToSave) <> vbNullString Then
Kill FileToSave
'MsgBox "Deleted the file"
End If
'***************Create New Table With Production History - this is t first word doc
**********************
LastProdHistRow = LastProdHistRow + 6 ' Adding additional rows to production history table
Set rRange = objDoc.Bookmarks(BkProdHist).Range
Set tblNew = objDoc.Tables.Add(Range:=rRange, NumRows:=LastProdHistRow, NumColumns:=10)
objDoc.Tables(2).Cell(3, 1).Range.Text = "Date"
objDoc.Tables(2).Cell(3, 2).Range.Text = "Volume"
objDoc.Tables(2).Cell(3, 3).Range.Text = "Begin Bates"
objDoc.Tables(2).Cell(3, 4).Range.Text = "End Bates"
objDoc.Tables(2).Cell(3, 5).Range.Text = "Documents"
objDoc.Tables(2).Cell(3, 6).Range.Text = "Redactions"
objDoc.Tables(2).Cell(3, 7).Range.Text = "Pages"
objDoc.Tables(2).Cell(3, 8).Range.Text = "Images"
objDoc.Tables(2).Cell(3, 9).Range.Text = "Natives"
objDoc.Tables(2).Cell(3, 10).Range.Text = "Slip-Sheets"
objDoc.Tables(2).Cell(LastProdHistRow + 6, 4).Range.Text = "Totals"
'************** End - Create Table with Production History
'Begin************** Copy Production History Array to Word Table *************************
'the loop only copies the first 10 columns of the array to the word table.
a = 4 ' The starting row of the table to begin copying data
For x = LBound(LastProdHist, 1) To UBound(LastProdHist, 1)
b = 1
For y = LBound(LastProdHist, 2) To UBound(LastProdHist, 2)
If y <= 9 Then
Debug.Print x, y, LastProdHist(x, y)
objDoc.Tables(2).Cell(a, b).Range.Text = LastProdHist(x, y)
b = b + 1
End If
Next y
a = a + 1
Next x
'End************** Produciton History Array to Word table ****************************
With objDoc.Tables(2)
.Range.Font.Size = 8
.Columns(2).Width = 40.5 'Date Column width
.Columns(3).Width = 81 'Begin Bates Column width
.Columns(4).Width = 81 'End Bates Colum width
.Columns(5).Width = 55 'Documents Column width
.Columns(6).Width = 55 'Redactions Column width
.Columns(7).Width = 37 'Pages Column width
.Columns(8).Width = 41 'Images Column width
.Columns(9).Width = 41 'Natives Column width
.Columns(10).Width = 62.5 'Slip-Sheet Column width
.Rows(LastProdHistRow).Range.Font.Bold = True
.Rows(3).Range.Font.Bold = True
.Rows(3).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Cell(LastProdHistRow, 5).Formula Formula:="=Sum(Above)"
.Cell(LastProdHistRow, 6).Formula Formula:="=Sum(Above)"
.Cell(LastProdHistRow, 7).Formula Formula:="=Sum(Above)"
.Cell(LastProdHistRow, 8).Formula Formula:="=Sum(Above)"
.Cell(LastProdHistRow, 9).Formula Formula:="=Sum(Above)"
.Cell(LastProdHistRow, 10).Formula Formula:="=Sum(Above)"
.Rows(LastProdHistRow).Borders(wdBorderTop).LineStyle = wdLineStyleSingle
.Rows(LastProdHistRow).Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
.Rows.SetLeftIndent LeftIndent:=-3.5, RulerStyle:=wdAdjustNone
End With
objDoc.Tables(2).Columns(1).Select
Set ObjSelection = objWord.Selection
ObjSelection.ParagraphFormat.Alignment = wdAlignParagraphRight
objDoc.Tables(2).Columns(2).Select
Set ObjSelection = objWord.Selection
ObjSelection.ParagraphFormat.Alignment = wdAlignParagraphCenter
objDoc.Tables(2).Columns(3).Select
Set ObjSelection = objWord.Selection
ObjSelection.ParagraphFormat.Alignment = wdAlignParagraphCenter
objDoc.Tables(2).Columns(4).Select
Set ObjSelection = objWord.Selection
ObjSelection.ParagraphFormat.Alignment = wdAlignParagraphCenter
objDoc.Tables(2).Columns(5).Select
Set ObjSelection = objWord.Selection
ObjSelection.ParagraphFormat.TabStops.Add Position:=InchesToPoints(0.4), Alignment:=wdAlignTabDecimal, Leader:=wdTabLeaderSpaces
objDoc.Tables(2).Columns(6).Select
Set ObjSelection = objWord.Selection
ObjSelection.ParagraphFormat.TabStops.Add Position:=InchesToPoints(0.4), Alignment:=wdAlignTabDecimal, Leader:=wdTabLeaderSpaces
objDoc.Tables(2).Columns(7).Select
Set ObjSelection = objWord.Selection
ObjSelection.ParagraphFormat.TabStops.Add Position:=InchesToPoints(0.5), Alignment:=wdAlignTabDecimal, Leader:=wdTabLeaderSpaces
objDoc.Tables(2).Columns(8).Select
Set ObjSelection = objWord.Selection
ObjSelection.ParagraphFormat.TabStops.Add Position:=InchesToPoints(0.5), Alignment:=wdAlignTabDecimal, Leader:=wdTabLeaderSpaces
objDoc.Tables(2).Columns(9).Select
Set ObjSelection = objWord.Selection
ObjSelection.ParagraphFormat.TabStops.Add Position:=InchesToPoints(0.25), Alignment:=wdAlignTabDecimal, Leader:=wdTabLeaderSpaces
objDoc.Tables(2).Columns(10).Select
Set ObjSelection = objWord.Selection
ObjSelection.ParagraphFormat.TabStops.Add Position:=InchesToPoints(0.4), Alignment:=wdAlignTabDecimal, Leader:=wdTabLeaderSpaces
With objDoc.Tables(2)
.Rows(2).Cells.Merge
.Cell(2, 1).Range.Text = "DOCUMENT PRODUCTION HISTORY"
.Cell(2, 1).Range.Style = ("Heading 1")
.Cell(LastProdHistRow, 4).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
.Rows(LastProdHistRow - 2).Shading.ForegroundPatternColor = wdColorAutomatic
.Rows(LastProdHistRow - 2).Shading.BackgroundPatternColor = -553582797
End With
'Begin************** Setting up Email to send to reqestor *************************
'****
'**** objDoc2 has been opend for the this reason
Set bkRange = objDoc2.Bookmarks(bkUserName).Range
bkRange.Text = LastProdHist(LastProdHistRow - 6, 13)
Set bkRange = objDoc2.Bookmarks(BkVolume).Range
bkRange.Text = LastProdHist(LastProdHistRow - 6, 1)
Set bkRange = objDoc2.Bookmarks(bkProductionSearch).Range
bkRange.Text = LastProdHist(LastProdHistRow - 6, 10)
Set bkRange = objDoc2.Bookmarks(bkArchivePassword).Range
bkRange.Text = LastProdHist(LastProdHistRow - 6, 11)
Set bkRange = objDoc2.Bookmarks(bkProductionDownload).Range
bkRange.Text = LastProdHist(LastProdHistRow - 6, 12)
objWord.Documents("C:\temp\DOC1.docm").Activate
objDoc.Tables(2).Range.Select
Selection.Copy
objWord.Documents(""C:\temp\DOC2.docm").Activate
Set bkRange = objDoc2.Bookmarks(bkProductionHistory).Range
bkRange.Paste
'End**************** Setting up Email to send to reqestor *************************
'Debug.Print FileToSave
objDoc.ExportAsFixedFormat OutputFileName:= _
"C:\Temp\" & FileToSave, ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=True, OptimizeFor:=wdExportOptimizeForPrint, Range:= _
wdExportAllDocument, From:=1, To:=1, Item:=wdExportDocumentContent, _
IncludeDocProps:=True, KeepIRM:=True, CreateBookmarks:= _
wdExportCreateNoBookmarks, DocStructureTags:=True, BitmapMissingFonts:= _
True, UseISO19005_1:=False
'ChangeFileOpenDirectory "C:\Temp\"
objDoc.MailMerge.DataSource.Close
'objDoc.Close SaveChanges:=wdDoNotSaveChanges
'objWord.Application.Quit
End Function
问题很简单——你没有资格Selection.Copy。应该是 objWord.Selection.Copy.
最好还是使用：
objDoc.Tables(2).Range.Copy
objDoc2.Bookmarks(bkProductionHistory).Range.Paste
您不需要激活任何一个文件。此外，复制所需的全部是：
objDoc2.Bookmarks(bkProductionHistory).Range.FormattedText = objDoc.Tables(2).Range.FormattedText