Thanks for your interest and help. Below is the code with my changes. In regards to the code you provided, I am unsure where I would place that.
Option Explicit
Private Const strWorkBook As String = "C:\Path\Data.xlsx"
Private Const strSheet As String = "Sheet1"
Sub Test()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
ExtractCSV olMsg
lbl_Exit:
Exit Sub
End Sub
Sub ExtractCSV(olItem As MailItem)
'An Outlook macro by Graham Mayor
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim i As Long, j As Long
Dim strSaveFldr As String
Dim vData As Variant
Dim strValues As String
strSaveFldr = Environ("Temp") & Chr(92)
On Error GoTo CleanUp
If olItem.Attachments.Count > 0 Then
For j = olItem.Attachments.Count To 1 Step -1
Set olAttach = olItem.Attachments(j)
If olAttach.FileName Like "*.csv" Then
strFname = olAttach.FileName
olAttach.SaveAsFile strSaveFldr & strFname
Select Case olItem.Subject
Case "Facility A Dashboard"
j = 24
Case "Facility B Dashboard"
j = 26
Case "Facility C Dashboard"
j = 24
Case "Facility D Dashboard"
j = 26
Case Else: GoTo CleanUp
End Select
vData = Split(DataToExcel(strSaveFldr & strFname, j), Chr(44))
strValues = Format(Now - 1, "mm-dd-yyyy" & "', '" olItem.Subject & "', '" & vData(5)
WriteToWorksheet strWorkBook, strSheet, strValues
Kill strSaveFldr & strFname
Exit For
End If
Next j
End If
CleanUp:
Set olAttach = Nothing
Set olItem = Nothing
lbl_Exit:
Exit Sub
End Sub
Private Function DataToExcel(strFname As String, lngRow As Long)
'An Outlook macro by Graham Mayor
Dim i As Long
Dim strData As String
Dim FileNum As Integer
FileNum = FreeFile()
i = 0
Open strFname For Input As #FileNum
Do Until EOF(1)
i = i + 1
Line Input #1, strData
If i = lngRow Then
strData = Replace(strData, Chr(34), "")
strData = Replace(strData, Chr(44) & Chr(44), "")
DataToExcel = strData
Exit Do
End If
Loop
Close #FileNum
lbl_Exit:
Exit Function
End Function
Private Function WriteToWorksheet(strWorkBook As String, _
strRange As String, _
strValues As String)
'An Office macro by Graham Mayor
Dim ConnectionString As String
Dim strSQL As String
Dim CN As Object
ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkBook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
strSQL = "INSERT INTO [" & strRange & "$] VALUES('" & strValues & "')"
Set CN = CreateObject("ADODB.Connection")
Call CN.Open(ConnectionString)
Call CN.Execute(strSQL, , 1 Or 128)
CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function