將 Outlook .csv 附件導入 Excel

Question

我在 Outlook 中每天收到一封帶有 .csv 附件的電子郵件，我將其保存、重命名並將值復制到目標 excel 文件中，並嘗試使用 Outlook 中的宏自動執行此過程。 目前在我的宏下面，文件的保存和重命名工作正常，但我正在努力將值復制/粘貼到我的目標 excel 文件中。 我發現了兩個問題：

1. 目標 excel 文件具有帶日期的列（在第 2 行），我想匹配源文件名中的日期以標識我需要將值粘貼到的列。 這當前返回 0 而不是索引匹配。 目標excel文件第2行中的日期是上一列日期加1的公式。 我擁有的另一個匹配功能正常工作。 為什么不是這個？
2. 當我使用 Range("D10:D22").Copy 等固定地址時，我的 Range().Copy/Paste 有效，但當我使用如下所示的動態單元格引用時則無效。 為什么這不起作用/我怎樣才能讓它依賴於我的匹配函數的結果？

先感謝您。

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(...) 

如果沒有匹配，它不會引發運行時錯誤，而是向ColumnNumber返回一個錯誤值。 然后您可以使用If IsError(ColumnNumber)測試不匹配。

#2：這里例如：

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

Range限定為wbSource.Sheets(TabName)但在常規模塊中，對Cells的兩次調用將默認為 ActiveSheet（如果它是不同的工作表，則會引發錯誤。

你可以這樣解決：

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

請參閱： 工作表和單元格的默認范圍和范圍是多少？

僅供參考，由於 CSV 文件在 Excel 中打開時只能有一個工作表，因此您可以安全地使用Worksheets(1)而不必擔心選項卡名稱是什么。