将数据从 Excel 复制到 Word 而不覆盖现有文本

Question

我每天都在 Excel 中生成一份报告。我从电子邮件中提取报告，进行一些过滤，写下一些数字并从 Excel 报告中复制一些表格信息。

Excel 中的表格，假设它在 A-Z 列中有数据。我正在尝试根据某些过滤条件将数据从 Excel 复制到 Word 中。大部分我都记下来了。

当我将过滤后的表格从 Excel 复制到 Word 中，并且表格被粘贴在某些文本下方时，表格会覆盖 Word 文档中的文本。

Const olFolderInbox As Integer = 6
'~~> Path for the attachment
Const AttachmentPath As String = "C:\Users\....."

Sub DownloadAttachmentFirstUnreadEmail()
Dim oOlAp As Object, oOlns As Object, oOlInb As Object, LastRow As Long, objDoc As Object, objWord As Object, objSelection As Object, nonProdCount As Integer, nonProdDT As Integer
Dim oOlItm As Object, oOlAtch As Object, fname As String, sFound As String, totalRowCount As Integer, wFound As String, wdRange As Word.Range, str As String, nonProdCopyToWord As Long
Dim wb As Workbook, uRng As Range

'~~> New File Name for the attachment
Dim NewFileName As String
NewFileName = "MorningOpsFile " & Format(Date, "MM-DD-YYYY")
'~~> Get Outlook instance
Set oOlAp = GetObject(, "Outlook.application")
Set oOlns = oOlAp.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox).Folders("Folder Name Here")
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add
objWord.Visible = True
Set objSelection = objWord.Selection

'~~> Check if there are any actual unread emails
If oOlInb.Items.Restrict("[UnRead] = True").Count = 0 Then
    MsgBox "NO Unread Email In Inbox"
    Exit Sub
End If

'~~> Extract the attachment from the 1st unread email
For Each oOlItm In oOlInb.Items.Restrict("[UnRead] = True")
    '~~> Check if the email actually has an attachment
    If oOlItm.Attachments.Count <> 0 Then
        For Each oOlAtch In oOlItm.Attachments
            '~~> Download the attachment
            oOlAtch.SaveAsFile NewFileName & oOlAtch.Filename
            Exit For
        Next
    Else
        MsgBox "The First item doesn't have an attachment"
    End If
    Exit For
Next

'~~> Mark 1st unread email as read
For Each oOlItm In oOlInb.Items.Restrict("[UnRead] = True")
    oOlItm.UnRead = False
    DoEvents
    oOlItm.Save
    Exit For
    Next
'--> Search for downloaded file without knowing exact filename
sFound = Dir(ActiveWorkbook.Path & "\*File Search String*.xlsx")
If sFound <> "" Then
Workbooks.Open Filename:=ActiveWorkbook.Path & "\" & sFound
End If

Set uRng = ActiveSheet.Range("A1:A2")

'--> Set variable for last row in sheet containing data
LastRow = Sheets("Sheet1).Cells(Rows.Count, 1).End(xlUp).Row

'--> Apply filter to look for today's changes
With Sheets("Sheet 1").Select
Range("$A$1:AB" & LastRow).AutoFilter Field:=3, Criteria1:= _
    xlFilterToday, Operator:=xlFilterDynamic
    '--> Get a total row count of today's changes
 totalRowCount = ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
 '--> Printout total rowcount number
' MsgBox totalRowCount

Set objDoc = objWord.Documents.Open("C:\Users\....docx")
objWord.Visible = True
'objWord.Activate
objDoc.Content.Select
objDoc.Content.Delete
objWord.Selection.TypeText vbNewLine
objWord.Selection.TypeText "Good Morning All" & vbNewLine
objWord.Selection.TypeText "We have " & totalRowCount & " total current day changes" & vbNewLine
End With

'--> Filter for non-Prod changes
ActiveSheet.Range("$A$1:AB" & LastRow).AutoFilter Field:=10, Criteria1:="QA", _
        Operator:=xlOr, Criteria2:="Development"
'-->Count non-Prod changes
nonProdCount = ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
'--> Put count of non-Prod changes in Word document
objWord.Selection.TypeText "We have " & nonProdCount & " non-production changes" & vbNewLine
'--> Filter for non-Prod changes with downtime
ActiveSheet.Range("$A$1:AB" & LastRow).AutoFilter Field:=11, Criteria1:="<>", _
    Operator:=xlAnd
'--> Count non-Prod changes with downtime
nonProdDT = ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
'--> Add non-prod downtime count to Word
objWord.Selection.TypeText nonProdDT & " with downtime" & vbNewLine

'--> Copy non-Prod rows with downtime from Excel to Word
'Set uRng = Union(Range("A1:A" & LastRow).SpecialCells(xlCellTypeVisible), (Range("G1:H" & LastRow).SpecialCells(xlCellTypeVisible)))
'uRng.Copy
ActiveSheet.Range("B1:F" & LastRow).EntireColumn.Hidden = True
ActiveSheet.Range("N1:Q" & LastRow).EntireColumn.Hidden = True
ActiveSheet.Range("Z1:AB" & LastRow).EntireColumn.Hidden = True

ActiveSheet.Range("A1:Y" & LastRow).SpecialCells(xlCellTypeVisible).Copy

objWord.Selection.TypeText vbNewLine
objDoc.Content.Paste

End Sub

如何在不覆盖 Word 文档中的内容的情况下将 Excel 中的过滤表复制到 Word？

Answer 1

这是你的问题：

objWord.Selection.TypeText vbNewLine
objDoc.Content.Paste

objDoc.Content 是文档的整个主体——整个“内容”，不包括页眉、页脚、对象中具有“文本换行”格式的任何文本等。

您可以使用objWord.Selection.Paste，类似于上面的第一行。

从程序员的角度来看，最好使用 Word Range 对象。比如：

Dim wdRange as Object
Set wdRange = objWord.Selection.Range
wdRange.InsertParagraph
wdRange.Collapse 0
wdRange.Paste

这被认为是可取的原因是不依赖于选择更可靠。从理论上讲，在您的代码运行时，某些东西可能会改变选择。 Range 将保持静态。这也使得更容易理解插入/操作的位置（代码更“自我记录”）。