Excel VBA代码为我工作，但不是其他人

Question

我有一些代码可以做很多事情，对我来说都很好，但对其他人来说却不行。对于其他人，它打开Word，但不填充任何数据和错误。我是新人，所以不知道为什么这对我有用，但不是其他人，我想了解未来的编码。

谢谢你看一看。

这是在"wrdApp.Selection.Paste"上给出错误的代码部分。行

Sheets("Sch1A").Range("Print_Area").Copy
With objWord
wrdApp.Selection.Paste

这不是完整的代码集，但这是包含错误和相关变量的部分。

'Below is where the embedded word doc opens and pastes in the code
Dim wrdApp As Word.Application
Set wrdApp = CreateObject("Word.Application")
Dim sh As Shape
Dim objWord As Object, objNewDoc As Object ''Word.Document
'Dim objOLE As New OLEObject
Dim objOLE As OLEObject
Dim wSystem As Worksheet
Dim cell As Range

Set wSystem = Worksheets("Schedule variables")
''The shape holding the object from 'Create from file'
''Object 2 is the name of the shape
Set sh = wSystem.Shapes("PageBreak")
''The OLE Object contained
Set objOLE = sh.OLEFormat.Object
'Instead of activating in-place, open in Word
objOLE.Verb xlOpen
Set objWord = objOLE.Object 'The Word document

Dim objUndo As Object 'Word.UndoRecord
'Be able to undo all editing performed by the macro in one step
Set objUndo = objWord.Application.UndoRecord
objUndo.StartCustomRecord "Edit In Word"

Sheets("Sch1A").Range("Print_Area").Copy
With objWord
wrdApp.Selection.Paste
wrdApp.Selection.InsertBreak
End With

'Add footer
wrdApp.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
wrdApp.Selection.Font.Size = 7
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeText ThisWorkbook.Sheets("Schedule variables").Range("S1").Text
'wrdApp.Selection.TypeText vbTab & vbTab & "             " & ThisWorkbook.Sheets("Schedule variables").Range("O5").Text
wrdApp.Selection.TypeParagraph
wrdApp.Selection.Font.Size = 7
wrdApp.Selection.TypeText ThisWorkbook.Sheets("Schedule variables").Range("S2").Text
wrdApp.Selection.TypeParagraph
wrdApp.Selection.Font.Size = 7
wrdApp.Selection.TypeText ThisWorkbook.Sheets("Schedule variables").Range("S3").Text
'wrdApp.Selection.TypeParagraph
'wrdApp.Selection.TypeText vbTab & vbTab & "             " & ThisWorkbook.Sheets("Schedule variables").Range("O7").Text
wrdApp.ActiveWindow.ActivePane.View.SeekView = 0

Sheets("Sch1B").Range("Print_Area").Copy
With objWord
wrdApp.Selection.Paste
wrdApp.Selection.InsertBreak
End With

Sheets("Sch2").Range("Print_Area").Copy
With objWord
wrdApp.Selection.Paste
wrdApp.Selection.InsertBreak
End With

Sheets("Sch3").Range("Print_Area").Copy
With objWord
wrdApp.Selection.Paste
wrdApp.Selection.InsertBreak
End With

'Password protect and only allow track changes in Word document
'wrdApp.ActiveDocument.Protect password:="wildcard", NoReset:=False, Type:= _
'       wdAllowOnlyComments, UseIRM:=False, EnforceStyleLock:=False

'Save as client name to same path the Excel file is saved and undo everything for the embedded document to be clean
With objWord
objWord.SaveAs2 ActiveWorkbook.Path & "" & Sheets("Schedule variables").Range("S1").Value
objUndo.EndCustomRecord
Set objUndo = Nothing
objWord.Undo
.Application.Quit False
End With

Set objWord = Nothing
Set WordDoc = Nothing
Set WordApp = Nothing

'TURN BACK ON IN FINAL CODE
'Sheets("Schedule variables").Visible = False
'Sheets("Sch1A").Visible = False
'Sheets("Sch1B").Visible = False
'Sheets("Sch2").Visible = False
'Sheets("Sch3").Visible = False
'ThisWorkbook.Protect password:="wildcard"

Application.ScreenUpdating = True

'Call EmailFile

'Show message box where schedule was saved down
MsgBox Sheets("Schedule variables").Range("S1").Text & " has been saved in this folder " & ActiveWorkbook.Path

End Sub

Answer 1

快速解决问题的方法在于如何将范围粘贴到Word中。OLE对象不适用于进程。

下面的例子应该给你一个模板来应用到你的解决方案。

Option Explicit
Sub CopyPrintAreasToWord()
Dim wordApp As Word.Application
Dim wordDoc As Word.Document
Set wordApp = CreateObject("Word.Application")
wordApp.Visible = True

Set wordDoc = wordApp.Documents.Add
Dim ws As Worksheet
Set ws = Sheet1

Dim currentPrintArea As Range
Set currentPrintArea = ws.Range("Print_Area")
currentPrintArea.Copy

wordDoc.Paragraphs(1).Range.PasteExcelTable LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
End Sub

Answer 2

我在这里发布第二个答案，因为在深入研究解决方案的过程中，我遇到了一个问题，我认为OP的问题和代码并没有真正解决。那就是:工作表的实际可打印区域是什么，如果范围大于单个页面会发生什么?

我的另一个答案(希望)直接而简洁地解决了OP的问题。这个答案试图解决这个更大的问题，以防万一。

下面的函数没有并入OP的代码中，也没有并入我的其他答案中。但我在这里是为社区提供的。

Option Explicit
Sub TestGettingPrintRanges()
Dim ws As Worksheet
Set ws = Sheet2

Dim thisPage As Range
Dim i As Long
For i = 1 To (ws.HPageBreaks.Count + 1)
Set thisPage = GetPrintPageRange(i, ws)
Debug.Print "Page " & i; " print area = " & thisPage.Address
Next i
End Sub
Function GetPrintPageRange(ByVal pageNumber As Long, ByRef ws As Worksheet) As Range
'--- returns the range defined by the worksheet print area, as assigned
'    to the given page number
'------ NOTE: currently assumes that VPageBreaks.Count = 0

On Error Resume Next
Dim fullPrintArea As Range
Set fullPrintArea = ws.Range("Print_Area")
If fullPrintArea Is Nothing Then
Debug.Print "ERROR: print area has not been set!"
Exit Function
End If

Dim upperLeftCell As Range
Set upperLeftCell = fullPrintArea.Resize(1, 1)

'--- strangeness working with HPageBreaks.Count is that there *MIGHT* be one
'    more page than the count indicates.
Dim thisPageArea As Range
If (pageNumber > (ws.HPageBreaks.Count + 1)) Then
Debug.Print "ERROR: page number " & pageNumber & _
" is greater than page count (" & ws.HPageBreaks.Count & ")"
Set GetPrintPageRange = Nothing
ElseIf (pageNumber <= ws.HPageBreaks.Count) Then
With ws
Dim lowerRightCell As Range
Set lowerRightCell = fullPrintArea.Resize(1, 1).Offset(fullPrintArea.Rows.Count - 1, _
fullPrintArea.Columns.Count - 1)

Dim columnsInThisPage As Long
columnsInThisPage = lowerRightCell.Column - upperLeftCell.Column + 1

Dim rowsInThisPage As Long
If (pageNumber = 1) Then
rowsInThisPage = .HPageBreaks(pageNumber).Location.Row - upperLeftCell.Row
Set thisPageArea = upperLeftCell.Resize(rowsInThisPage, columnsInThisPage)
Else
Dim prevPageBreakCell As Range
Set prevPageBreakCell = ws.HPageBreaks(pageNumber - 1).Location
rowsInThisPage = .HPageBreaks(pageNumber).Location.Row - prevPageBreakCell.Row
Set thisPageArea = .Range(.Cells(.HPageBreaks(pageNumber - 1).Location.Row, upperLeftCell.Column), _
.Cells(.HPageBreaks(pageNumber).Location.Row - 1, _
upperLeftCell.Column + columnsInThisPage - 1))
End If
End With
Else
'--- this is the special case to check if there is another print area
'    beyond the given page count or if the HPageBreaks.Count is zero,
'    we may still have a "Print_Area" range that's less than a full page
If (ws.HPageBreaks.Count = 0) Then
Set thisPageArea = ws.Range("Print_Area")
Else
Dim lastPageNumber As Long
lastPageNumber = ws.HPageBreaks.Count

Dim lastPageCell As Range
Set lastPageCell = ws.HPageBreaks(lastPageNumber).Location
If (fullPrintArea.Rows(fullPrintArea.Rows.Count).Row - lastPageCell.Row) > 0 Then
'--- we have an extra page here, so...
Set thisPageArea = ws.Range(ws.Cells(lastPageCell.Row, upperLeftCell.Column), _
ws.Cells(fullPrintArea.Rows(fullPrintArea.Rows.Count).Row, _
fullPrintArea.Columns(fullPrintArea.Columns.Count).Column))
End If
End If
End If
Set GetPrintPageRange = thisPageArea
End Function