如何将Outlook表格复制到已有Excel文件？附现有VBA代码

没问题，我帮你调整这段代码，让它把选中邮件里的表格粘贴到你指定的已有Excel文件里，而不是自动新建文件~

核心修改点 #

原代码里xlApp.Workbooks.Add是新建Excel文件的关键，我们需要把这部分替换成打开/获取已存在的Excel工作簿，同时指定好文件路径和目标工作表。

修改后的完整代码 #

Sub CopyOutlookTablesToExistingExcel()
    Dim item As MailItem
    Dim x As Integer
    Dim r As Object ' Word.Range
    Dim doc As Object ' Word.Document
    Dim xlApp As Object
    Dim wkb As Object
    Dim wks As Object
    Dim excelFilePath As String
    
    ' ********** 这里替换成你的已有Excel文件路径 **********
    excelFilePath = "C:\Users\YourName\Documents\YourExistingFile.xlsx"
    
    ' 初始化Excel应用
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True ' 让Excel可见，方便查看
    
    On Error Resume Next ' 先尝试获取已打开的工作簿
    Set wkb = xlApp.Workbooks(Filename:=excelFilePath)
    On Error GoTo 0
    
    ' 如果工作簿没打开，就打开它
    If wkb Is Nothing Then
        Set wkb = xlApp.Workbooks.Open(excelFilePath)
    End If
    
    ' 指定要粘贴的工作表（这里用Sheet1，你可以改成你的目标表名，比如"数据汇总"）
    Set wks = wkb.Sheets("Sheet1")
    
    ' 遍历选中的邮件
    For Each item In Application.ActiveExplorer.Selection
        Set doc = item.GetInspector.WordEditor
        ' 遍历邮件里的所有表格
        For x = 1 To doc.Tables.Count
            Set r = doc.Tables(x)
            r.Range.Copy
            ' 找到工作表最后一行的下一行，粘贴表格
            wks.Cells(wks.Rows.Count, 1).End(xlUp).Offset(1).Select
            wks.Paste
        Next x
    Next item
    
    ' 可选：保存Excel文件
    wkb.Save
    
    ' 释放对象（好习惯）
    Set r = Nothing
    Set doc = Nothing
    Set wks = Nothing
    Set wkb = Nothing
    Set xlApp = Nothing
End Sub

关键说明 #

• 文件路径：一定要把excelFilePath的值改成你实际的Excel文件绝对路径，路径里的斜杠要用\或者转义的\\
• 工作表指定：如果你的目标工作表不是Sheet1，把wkb.Sheets("Sheet1")里的Sheet1改成你的工作表名称
• 重复打开判断：代码里先检查文件是否已经打开，如果已经打开就直接用，避免重复打开导致错误
• 粘贴位置：wks.Cells(wks.Rows.Count, 1).End(xlUp).Offset(1)会自动找到A列最后一行的下一行，避免覆盖已有数据

注意事项 #

• 确保你的Excel文件没有被其他程序锁定（比如正在编辑没关闭）
• 如果需要粘贴时保留表格格式，原代码的Paste方法已经可以保留，要是需要特殊格式可以改成wks.PasteSpecial xlPasteAll之类的参数（根据需求调整）

内容的提问来源于stack exchange，提问作者Waleed Malik