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:
- 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?
- 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