将 Outlook .csv 附件导入 Excel

Question

我每天都会在 Outlook 中收到一封带有 .csv 附件的电子邮件，我保存、重命名并将值复制到目标 excel 文件中，并试图在 Outlook 中使用宏自动执行此过程。目前在我下面的宏中，文件的保存和重命名工作正常，但我正在努力将 copy/pasting 值放入我的目标 excel 文件中。我发现了两个问题：

目标 excel 文件包含带日期的列（在第 2 行），我想匹配源文件名中的日期以确定我需要将值粘贴到的列。这当前返回 0 而不是索引匹配。目标 excel 文件第 2 行中的日期是将前一列中的日期加 1 的公式。我拥有的另一个匹配功能工作正常。为什么不是这个？
My Range().Copy/Paste 在我使用像 Range("D10:D22").Copy 这样的固定地址时有效，但在我使用如下动态单元格引用时无效。为什么这不是 working/how 我可以让它依赖于我的匹配函数的结果吗？

提前致谢。

Public Sub SaveAttachments()

Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFileName As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim sSubject As String
Dim sSubjectMonthDay As String
Dim sSubjectYear, sSubjectMonth, sSubjectDay As Long

'----to copy data to target spreadsheet----

Dim xExcelApp As Excel.Application

Dim wbSource As Excel.Workbook
Dim wbDestination As Excel.Workbook
Dim pathname As String
Dim TabName As String
Dim RptDate As Date
Dim ColumnNumber, M1Row As Long

'----^end copy data to target spreadsheet----

    On Error Resume Next

    ' Instantiate an Outlook Application object.
    Set objOL = Application

    ' Get the collection of selected objects.
    Set objSelection = objOL.ActiveExplorer.Selection

    ' Set the Attachment folder.
    strFolderpath = "C:\Users\kdmiller\Documents\OLAttachments\"
    
    ' Check each selected item for attachments.
    For Each objMsg In objSelection

    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
        
    If lngCount > 0 Then
    
    For i = lngCount To 1 Step -1
    
    ' Obtain Email Subject Title
    sSubject = objMsg.Subject

    ' Extract Month and Day from Subject Line
    sSubjectMonthDay = Mid(sSubject, 18, Len(sSubject) - 17 - 5)
        If Len(sSubjectMonthDay) = 5 Then
            sSubjectMonthDay = Replace(sSubjectMonthDay, "/", "")
            sSubjectMonth = Left(sSubjectMonthDay, 2)
            sSubjectDay = Right(sSubjectMonthDay, 2)
        ElseIf Len(sSubjectMonthDay) = 3 Then
            sSubjectMonth = Left(sSubjectMonthDay, 1)
            sSubjectDay = Right(sSubjectMonthDay, 1)
            sSubjectMonthDay = "0" & Left(sSubjectMonthDay, 1) & "0" & Right(sSubjectMonthDay, 1)
        ElseIf InStr(sSubjectMonthDay, "/") = 2 Then
            sSubjectMonth = Left(sSubjectMonthDay, 1)
            sSubjectDay = Right(sSubjectMonthDay, 2)
            sSubjectMonthDay = "0" & Replace(sSubjectMonthDay, "/", "")
        Else
            sSubjectMonth = Left(sSubjectMonthDay, 2)
            sSubjectDay = Right(sSubjectMonthDay, 1)
            sSubjectMonthDay = Left(sSubjectMonthDay, 2) & "0" & Right(sSubjectMonthDay, 1)
        End If
    
    'Extract Year from Subject Line
    sSubjectYear = Right(sSubject, 4)

    ' Get the file name.
    strFileName = "Drpt " & sSubjectYear & sSubjectMonthDay & ".csv"
    
    ' Combine with the path to the Temp folder.
    strFile = strFolderpath & strFileName
    
    ' Save the attachment as a file.
    objAttachments.Item(i).SaveAsFile strFile
    
    '----to copy data to target spreadsheet----
    
    Set xExcelApp = CreateObject("Excel.Application")
    
    'destination file pathname
    pathname = "C:\Users\kdmiller\Desktop\ImportDestinationTest.xlsx"

    'open the source workbook and select the source sheet
    Set wbSource = xExcelApp.Workbooks.Open(FileName:=strFile)
    
    'Identify tab name for source file
    TabName = Left(strFileName, Len(strFileName) - 4)
    
    'Identify row data begins
    M1Row = xExcelApp.WorksheetFunction.Match("M1", wbSource.Sheets(TabName).Range("c:c"), 0)
  
    'Set the destition workbook variable
    Set wbDestination = xExcelApp.Workbooks.Open(FileName:=pathname)
    
    'Determine Destination Column
    RptDate = sSubjectMonth & "/" & sSubjectDay & "/" & sSubjectYear
    ColumnNumber = xExcelApp.WorksheetFunction.Match(RptDate, wbDestination.Sheets("Drpt").Range("2:2"), 0)
                      
    'copy the source range
    wbSource.Sheets(TabName).Range(Cells(M1Row, 4), Cells(M1Row + 12, 4)).Copy
    
    'paste the values
    wbDestination.Sheets("Drpt").Range(Cells(19, ColumnNumber), Cells(31, ColumnNumber)).PasteSpecial (xlPasteValues)
    
    'copy the source range
    wbSource.Sheets(TabName).Range(Cells(M1Row, 7), Cells(M1Row + 12, 7)).Copy
    
    'paste the values
    wbDestination.Sheets("Drpt").Range(Cells(34, ColumnNumber), Cells(46, ColumnNumber)).PasteSpecial (xlPasteValues)
    
    'copy the source range
    wbSource.Sheets(TabName).Range(Cells(M1Row + 6, 10), Cells(M1Row + 12, 10)).Copy
       
    'paste the values
    wbDestination.Sheets("Drpt").Range(Cells(49, ColumnNumber), Cells(55, ColumnNumber)).PasteSpecial (xlPasteValues)
    
    'Close workbook
    wbSource.Close SaveChanges:=False
    
    'Calculate, save, and close destination workbook
    wbDestination.Calculate
    wbDestination.Close SaveChanges:=True

    '----end copy data to destination spreadsheet----
    
    Next i
    End If
    
    Next
    
ExitSub:

Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

Answer 1

#1：如果没有 On Error Resume Next，您可能会遗漏意外错误。 OERN 的使用应仅限于您绝对需要的地方，并应尽快使用 On Error Goto 0 取消。

而不是：

ColumnNumber = xExcelApp.WorksheetFunction.Match(...)

您可以将 ColumnNumber 声明为 Variant 并使用

ColumnNumber = xExcelApp.Match(...)

如果没有匹配，它不会引发运行次错误，而是 returns 一个 ColumnNumber 的错误值。然后你可以使用 If IsError(ColumnNumber).

测试不匹配

#2：例如：

wbSource.Sheets(TabName).Range(Cells(M1Row, 7), Cells(M1Row + 12, 7)).Copy

Range 的作用域为 wbSource.Sheets(TabName) 但在常规模块中，对 Cells 的两次调用将默认为 ActiveSheet（如果它是不同的 [=44，则会引发错误） =].

你可以这样解决：

With wbSource.Sheets(TabName)
    .Range(.Cells(M1Row, 7), .Cells(M1Row + 12, 7)).Copy
End With

参见：

仅供参考，因为 CSV 文件在 Excel 中打开时只能有一个作品sheet，您可以安全地使用 Worksheets(1) 而不必担心标签名称是什么。

将 Outlook .csv 附件导入 Excel

Import Outlook .csv attachment into Excel

csv

excel

outlook

vba