Download an attachment when an email arrives and copy its contents into a summary.

[sands2038]

I'm convinced this can be done but it seems it is way beyond my skill level (I'm a total novice)

Several times a day a customer sends me a .csv file that I use to generate an order, I need to keep a running log of all of the data in these .csv files in a summary workbook.

I have a code in my summary workbook that takes every attachment I need from an Outlook folder and places them in a folder on my computer. Seems like a good starting point.

Sub Test()

    SaveAttachments "Test", "csv", "C:\Users\Desktop\Test"
    
End Sub


Sub SaveAttachments(OutlookFolderInInbox As String, _
                                 ExtString As String, DestFolder As String)
    Dim ns As Namespace
    Dim Inbox As MAPIFolder
    Dim SubFolder As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim I As Integer


    On Error GoTo ThisMacro_err


    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders(OutlookFolderInInbox)


    I = 0
    
    If SubFolder.Items.Count = 0 Then
        MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _
               vbInformation, "Nothing Found"
        Set SubFolder = Nothing
        Set Inbox = Nothing
        Set ns = Nothing
        Exit Sub
    End If


    If Right(DestFolder, 1) <> "\" Then
        DestFolder = DestFolder & "\"
    End If




    For Each Item In SubFolder.Items
        For Each Atmt In Item.Attachments
            If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
                FileName = DestFolder & " " & Atmt.FileName
                Atmt.SaveAsFile FileName
                I = I + 1
            End If
        Next Atmt
    Next Item


ThisMacro_exit:
    Set SubFolder = Nothing
    Set Inbox = Nothing
    Set ns = Nothing
    Exit Sub


ThisMacro_err:
    MsgBox "An unexpected error has occurred." _
         & vbCrLf & "Please note and report the following information." _
         & vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    Resume ThisMacro_exit


End Sub

I then need to copy the data from each .cvs and paste it into the summary workbook, I don't know if its easier to automatically process each file as it comes in or process a batch at a time, maybe on a schedule at the end of each day, I don't even really mind having to manually trigger the action to process all outstanding files. I should note that these emails can arrive whilst my PC is not on. I know you can trigger Macros from Outlook rules, that could be a good option

I have also have tested a code that opens a single .csv and copies the data where I need it, this seems to work.

Sub Copy()
Dim Import As Workbook
Dim Export As Workbook


Set Import = Workbooks("Test import.xlsm")
Set Export = Workbooks.Open("C:\User\Desktop\Test\Test Export.csv")


With Export.Sheets("Test Export").UsedRange
    Import.Sheets("Summary").Range("C" & Rows.Count).End(xlUp).Offset(1).Resize( _
        .Rows.Count, .Columns.Count) = .Value
End With


Export.Close


End Sub

I need help dealing with multiple .csv files, or a method for dealing with one at a time, and I also need to figure out how to add a date in Column B and a week number for that week in Column A for each row of data imported, the date is in the file name or I was think using Date Created might work.

Please ask if you need any more information.

Any help would be massively appreciated.

 

[Rijnsent]

Hi there,
this looks totally doable. What would your preferred setup be?

-have Outlook save the csv files to a folder
-open your summary.xls file to import all stored csvs

That sounds the easiest to me, do your csvs have some name-logic?
Cheers,
Koen

 

[sands2038]

Thanks for offering your support.
Yes, if outlook saves all the .csv's to a folder, then I can process them in batches whenever I need to from the summary.xls
The .csv's do have some kind of logic, but it seems to be a bit hit and miss, the last few I have received are:

welch 22 08 2018 A 2018_08_22_13_14_17
welch 22 08 2018 2 2018_08_22_15_09_29
welch 22 08 2018 1 2018_08_22_14_38_17
welch 22 08 2018 2018_08_22_11_01_03
welch 21 08 2018 1 2018_08_21_13_57_17
welch 21 08 2018 2018_08_21_10_23_41

 

[tonyyy]

sands2038,

Welcome to the Board.

I need help dealing with multiple .csv files, or a method for dealing with one at a time, and I also need to figure out how to add a date in Column B and a week number for that week in Column A for each row of data imported, the date is in the file name or I was think using Date Created might work.

You might consider the following...

Sub LoopThruFiles()
Application.ScreenUpdating = False
Dim wb As Workbook, wb2 As Workbook
Dim FolderName As String, fileName As String
Dim startRow As Long, lastRow As Long

Set wb = ThisWorkbook
FolderName = ThisWorkbook.Path & Application.PathSeparator
fileName = Dir(FolderName & "*.csv") 

Do While fileName <> ""
    If fileName <> wb.Name Then
        Set wb2 = Workbooks.Open(FolderName & fileName)
        With wb2.Sheets(1).UsedRange
            startRow = wb.Sheets("Summary").Range("C" & Rows.Count).End(xlUp).Offset(1).Row
            wb.Sheets("Summary").Range("C" & Rows.Count).End(xlUp).Offset(1).Resize( _
                .Rows.Count, .Columns.Count) = .Value
            lastRow = .Rows.Count
            
            wb.Sheets("Summary").Range("B" & startRow).Resize(lastRow, 1) _
                = FileDateTime(FolderName & fileName)
            wb.Sheets("Summary").Range("A" & startRow).Resize(lastRow, 1) _
                = WorksheetFunction.WeekNum(FileDateTime(FolderName & fileName), 1)
        End With
        wb2.Close savechanges:=False
    End If
    fileName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "The dishes are done, dude!"
End Sub

Place the workbook with this code into the folder that contains your .csv files. (Or, change the FolderName to the path with the .csv files.)

Be aware, the code will "copy" each of the .csv files in that folder, so running the code multiple times will result in duplicate data. You can either move already processed files to another folder, or clear the Summary sheet before starting the copy process. For example, you could paste the following line above the loop...

wb.Sheets("Summary").UsedRange.Clear

Cheers,

tonyyy

 

[sands2038]

I actually figured this out, I'm sure this is hideous to anyone who knows what they're doing, but it works.

There's also a bit of code in outlook that drops the files into the right folder.

Sub ScheduleImport()
   
    Dim vaFiles As Variant
    Dim i As Long, j As Long
    Dim schedule As Workbook, StockLog As Workbook
    Dim Summary As Worksheet
    Dim lastrowa As Integer, lastrowb As Integer
    Dim full As String, ref As String
    Dim oFS As Object
    Dim str As String
   
    Set StockLog = ActiveWorkbook
    Set Summary = StockLog.Sheets("Summary")
   
    vaFiles = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx", _
              Title:="Select files", MultiSelect:=True)
   
    If IsArray(vaFiles) Then
       
        For i = LBound(vaFiles) To UBound(vaFiles)
            Set schedule = Workbooks.Open(Filename:=vaFiles(i))
           
        With schedule.Sheets("Sheet1").Range("A1:T40")
            Summary.Range("C" & Rows.Count).End(xlUp).Offset(1).Resize( _
            .Rows.Count, .Columns.Count) = .Value
       
        End With
           
    lastrowa = Summary.Range("C1").End(xlDown).Row
    lastrowb = Summary.Range("A1").End(xlDown).Row
   
    full = ActiveWorkbook.Name
    ref = Mid(full, 1, 3)
    str = Application.ActiveWorkbook.FullName
    Set oFS = CreateObject("Scripting.FileSystemObject")
   
        For j = lastrowb + 1 To lastrowa
            Summary.Cells(j, "B") = ref
            Summary.Cells(j, "A") = WorksheetFunction.WeekNum(oFS.GetFile(str).DateCreated)
        Next j
   
            Set oFS = Nothing
            schedule.Close savechanges:=False
       
        Next i
   
    End If
 
    Kill "F:\Desktop\Schedules\*.*"
 
End Sub