0

I receive a daily email in Outlook with a .csv attachment that I save, rename, and copy values into a target excel file and am trying to automate this process with a macro in Outlook. Currently in my macro below the saving and renaming of the file works fine, but I am struggling with copy/pasting the values into my target excel file. I have identified two problems:

  1. The target excel file has columns with dates (in Row 2) and I want to match the date in the source file name to identify the column I need to paste the values into. This is currently returning 0 instead of the index match. The date in the target excel file Row 2 is a formula adding 1 to the date in the previous column. The other match function I have is working properly. Why is this one not?
  2. My Range().Copy/Paste works when I use a fixed address like Range("D10:D22").Copy but not when I'm using dynamic cell references like below. Why is this not working/how can I make it dependent on the results of my match functions?

Thank you in advance.

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
braX
  • 11,506
  • 5
  • 20
  • 33
kdmiller
  • 3
  • 2

1 Answers1

0

#1: Without On Error Resume Next you may be missing unexpected errors. Use of OERN should be restricted only to where you absolutely need it, and should be cancelled using On Error Goto 0 as soon as possible.

Instead of:

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

you can declare ColumnNumber as Variant and use

ColumnNumber = xExcelApp.Match(...) 

which does not raise a run-time error if no match is made, but instead returns an error value to ColumnNumber. Then you can test for no match using If IsError(ColumnNumber).

#2: Here for example:

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

Range is scoped to wbSource.Sheets(TabName) but in a regular module the two calls to Cells will default to the ActiveSheet (which will raise an error if it's a different sheet.

You could fix that like this:

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

See: What is the default scope of worksheets and cells and range?

FYI since CSV files can only have one worksheet when opened in Excel, you can safely use Worksheets(1) without worrying about what the tab name is.

Tim Williams
  • 154,628
  • 8
  • 97
  • 125
  • 1
    Thank you! The #2 fix makes sense and solved my problem and the #1 fix showed me the second match function wasn't finding a match. I added CLng() to the RptDate date variable and it worked! – kdmiller Jun 23 '21 at 15:45
  • See edit above on use of Match and handling cases where there's no match. – Tim Williams Jun 23 '21 at 16:04