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

之所以认为这是更可取的原因是，不依赖Selection更为可靠。从理论上讲，代码运行时可能会更改选择。范围将保持静态。这也使您更容易理解要在哪里插入/操作东西（代码更多是“自我记录”）。

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

1 个答案: