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