Excel 复制到 Word VBA

Question

我有一些代码正在使用宏记录器进行处理。 一句话，它总是以选择开始。 这篇文章https://exceloffthegrid.com/controlling-word-from-excel-using-vba/?unapproved=9388&moderation-hash=83a9b85f06d7f960463f59103685510b#comment-9388说我应该能够将此文档分配给一个变量并插入在.选择之前。 但是，在我键入文档变量后，选择方法不会出现在 VBE 中。 在我第一次使用单词选择对象 (Selection.EndKey) 时，我收到运行时错误 438“对象不支持此属性或方法”。 据我所知，GoTo 方法应该选择标题的开头。

Sub ExcelToWord()
'
' Select data in excel and copy to GIR
'
'
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
 
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim wdApp As Word.Application
    Dim GIR As Word.Document
    Dim GIRName As String
    Dim GEOL As String
    Dim Tbl As Long
        
    Set wdApp = New Word.Application '<<<  Create a Word application object
    wdApp.Visible = True '<<<< Open word so you can see any errors
    
    GIRName = Application.GetOpenFilename(Title:="Please choose GIR to open", _
                                          FileFilter:="Word Files *.docm* (*.docm*),")
    Set GIR = wdApp.Documents.Open(GIRName) '<< call Documents.Open on the word app
    
    'Loop through excel workbook to copy data
    Set wb = ThisWorkbook
    Set ws = ActiveSheet
    For Each ws In wb.Worksheets
        If UCase(ws.Name) <> "TEMPLATE" And ws.Visible = True Then
            ws.Name = Replace(ws.Name, "(Blank)", "NoGEOLCode")
            ws.Activate
            GEOL = Range("C9").Value
            Tbl = 1
            Range("A14").Select
            Range(Selection, Selection.End(xlToRight)).Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            
            'Paste each worksheet's data into word as new heading
            GIR.Activate
            GIR.Content.GoTo What:=wdGoToHeading, Which:=wdGoToFirst, Count:=5, Name:=""
            Selection.EndKey Unit:=wdLine
            Selection.TypeParagraph
            Selection.Style = ActiveDocument.Styles("Heading 2")
            Selection.TypeText Text:=GEOL
            Selection.TypeParagraph
            Selection.Tables.Add Range:=Selection.Range, NumRows:=53, NumColumns:=7, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitWindow
            With Selection.Tables(Tbl)
                If .Style <> "Table1" Then
                    .Style = "Table1"
                End If
                .ApplyStyleHeadingRows = True
                .ApplyStyleLastRow = False
                .ApplyStyleFirstColumn = True
                .ApplyStyleLastColumn = False
                .ApplyStyleRowBands = True
                .ApplyStyleColumnBands = False
            End With
            Selection.PasteAndFormat (wdFormatPlainText)
            Tbl = Tbl + 1
            Selection.GoTo What:=wdGoToSection, Which:=wdGoToFirst, Count:=6, Name:=""
            Selection.MoveUp Unit:=wdLine, Count:=1
            Selection.TypeParagraph
        End If
    Next
    
    GIR.Save
    
    
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
   
    
End Sub

Answer 1

您的代码有几个问题。

1. 出于各种原因使用Selection对象是不好的做法。 最好在 Excel 和 Word 中改用Range 。
2. 您将变量GIR设置为您打开的文档，但随后改用ActiveDocument 。
3. 您将表格添加到以标题 2样式设置格式的段落中。 要使表格样式正常工作，基础段落样式必须为Normal 。 这是因为 Word 中有一个样式层次结构，底部是表格样式，就在文档默认值之上，由Normal表示。
4. 您将变量NewTbl设置为指向您创建的表，但不再使用它。
5. With wdApp.Selection.Tables(Tbl)会出错，因为Selection只有一张表。

我已经重写了你的代码如下。 我没有更改 Word 代码的最后 3 行，因为我不确定您在那里到底在做什么，这是在没有处理文档的情况下尝试调试代码的结果。 我已经使用一些虚拟数据测试了这段代码，它在 O365 中对我有用。

Sub ExcelToWord()
  '
  ' Select data in excel and copy to GIR
  '
  '
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
  
  Dim wb As Workbook
  Dim ws As Worksheet
  Dim wdApp As Word.Application
  Dim GIR As Word.Document
  Dim GIRName As String
  Dim GEOL As String
  Dim Tbl As Long
  Dim NewTbl As Word.Table
  Dim wdRange As Word.Range
  
  Set wdApp = New Word.Application '<<<  Create a Word application object
  wdApp.Visible = True '<<<< Open word so you can see any errors
  
  GIRName = Application.GetOpenFilename(Title:="Please choose GIR to open", _
    FileFilter:="Word Files *.docm* (*.docm*),")
  Set GIR = wdApp.Documents.Open(GIRName) '<< call Documents.Open on the word app
  
  'Loop through excel workbook to copy data
  Set wb = ThisWorkbook
  Set ws = ActiveSheet
  For Each ws In wb.Worksheets
    If UCase(ws.Name) <> "TEMPLATE" And ws.Visible = True Then
      ws.Name = Replace(ws.Name, "(Blank)", "NoGEOLCode")
      ws.Activate
      GEOL = Range("C9").Value
      Tbl = 1
      Range("A14").Select
      Range(Selection, Selection.End(xlToRight)).Select
      Range(Selection, Selection.End(xlDown)).Select
      Selection.Copy
            
      'Paste each worksheet's data into word as new heading
            
      Set wdRange = wdApp.Selection.GoTo(What:=wdGoToHeading, _
        Which:=wdGoToFirst, Count:=4, Name:="")
      With wdRange
        '      wdApp.Selection.EndKey Unit:=wdLine
        '      wdApp.Selection.TypeParagraph
        .End = .Paragraphs(1).Range.End
        .InsertParagraphAfter
        .MoveStart wdParagraph
        .MoveEnd wdCharacter, -1
        '      wdApp.Selection.Style = ActiveDocument.Styles("Heading 2")
        .Style = GIR.Styles(wdStyleHeading2)
        '      wdApp.Selection.TypeText Text:=GEOL
        .Text = GEOL
        '      wdApp.Selection.TypeParagraph
        .InsertParagraphAfter
        .Collapse wdCollapseEnd
        .Style = GIR.Styles(wdStyleNormal)
        Set NewTbl = GIR.Tables.Add(Range:=wdRange, NumRows:=53, _
          NumColumns:=7, DefaultTableBehavior:=wdWord9TableBehavior, _
          AutoFitBehavior:=wdAutoFitWindow)
        '    With wdApp.Selection.Tables(Tbl)
        With NewTbl
          If .Style <> "Table1" Then
            .Style = "Table1"
          End If
          .ApplyStyleHeadingRows = True
          .ApplyStyleLastRow = False
          .ApplyStyleFirstColumn = True
          .ApplyStyleLastColumn = False
          .ApplyStyleRowBands = True
          .ApplyStyleColumnBands = False
          .Range.PasteAndFormat wdFormatPlainText
        End With
        '    wdApp.Selection.PasteAndFormat (wdFormatPlainText)
        '    Tbl = Tbl + 1
        wdApp.Selection.GoTo What:=wdGoToSection, Which:=wdGoToFirst, _
          Count:=6, Name:=""
        wdApp.Selection.MoveUp Unit:=wdLine, Count:=1
        wdApp.Selection.TypeParagraph
      End With
    End If
  Next
    
  GIR.Save
    
  Application.EnableEvents = True
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
   
End Sub