Solved

Part 5 to: Import more data into spreadsheet

Posted on 2013-06-07
34
238 Views
Last Modified: 2013-06-13
This is a continuation of http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28143009.html

The function correctly imports the email address of the sender into Col D but I also need to extract the email address from the csv or xls file and insert that into Col D - IF - the email in the file is different from the sender's email address.

So, if the sender's email address is joe@gmail.com and the email address in the csv or xls file is also joe@gmail.com then import joe@gmail.com into Col D.

However, if the email address in the csv or xls file is different, say susan@gmail.com then import into Col D: joe@gmail.com / susan@gmail.com

And each row in the csv or xls file is a different record (if there is more than one) and therefore would be entered into Applicant Status separately.
0
Comment
Question by:JaseSt
  • 18
  • 16
34 Comments
 
LVL 29

Expert Comment

by:gowflow
ID: 39229613
what do you mean by


And each row in the csv or xls file is a different record (if there is more than one) and therefore would be entered into Applicant Status separately.

gowflow
0
 

Author Comment

by:JaseSt
ID: 39229654
just that an xls file (not a csv) could have more than one record on it. Could have ten, therefore possibly ten different email addresses
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39229669
so far this version everywhere deals with one record. Honestly as it envolves a rather more complex structure to go thru several items I suggest we deal here on the email as for the first record like you requested if all is ok then you may ask specifically a related question to deal with the multiple records as this also may happen in csv as well and it makes it rather complex especially that you may have several attachments as well that overlap onto several rows.

Pls confirm before I post the solution.
gowflow
0
 

Author Comment

by:JaseSt
ID: 39229772
sure, that is fine. I thought we talked about the horizontal xls file having the possibility of having more than one record, but that's okay. We can deal with that later.

It will NOT happen with a csv file. Their will always be only one record in a csv file.
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39229834
this version answers your concern for Email like posted in the question in all of
Horizontal file
Vertical File
csv file

1) Make a copy of your latest file and give it a new name
2) goto VBA and select Saveattachements sub and delete it.
3) Copy paste the below code after any End Sub

Public Sub SaveAttachments()
On Error GoTo ErrHandler

Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim I As Long, J As Long, K As Long, L As Long, lTo As Long
Dim lngCount As Long
Dim LastRow As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim cCell As Range
Dim WS As Worksheet
Dim FileExt As String
Dim AttachRange As Range
Dim WB As Workbook
Dim WSAttach As Worksheet
Dim X, sFields, sLine
Dim ValidFile As Boolean
Dim sFile As String

    Set WS = ActiveSheet
        
    ' Get the path to your My Documents folder
    strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
    'On Error Resume Next
 
    ' Instantiate an Outlook Application object.
    Set objOL = CreateObject("Outlook.Application")
 
    ' Get the collection of selected objects.
    Set objSelection = objOL.ActiveExplorer.Selection
    'Set objSelection = objOL.GetNamespace("MAPI").Folders("CM Template")
    ' The attachment folder needs to exist
    ' You can change this to another folder name of your choice
 
    ' Set the Attachment folder to be this specific path as per Jaset request on Apr 29, 2013
    strFolderpath = strFolderpath & "\OLAttachments"
    'strFolderpath = "C:\Users\Michael\Sovereign Archives"
    
    ' Check each selected item for attachments.
    For Each objMsg In objSelection
 
        Set objAttachments = objMsg.Attachments
        lngCount = objAttachments.Count
         
        '---> Choose the color of the row
        Set cCell = ActiveCell
        LastRow = cCell.Row + 1
        Do
            '---> Locate the cell color of the last row above the current one
            LastRow = LastRow - 1
            LastRow = WS.Range("A" & LastRow).End(xlUp).Row
            
        Loop Until WS.Range("A" & LastRow).Interior.Color <> 16777215 Or LastRow = 1
        
        '---> Color the new row based on the results
        If WS.Range("A" & LastRow).Interior.Color = 14545386 Then
            WS.Range("A" & cCell.Row & ":AB" & cCell.Row).Interior.Color = 10147522
        Else
            WS.Range("A" & cCell.Row & ":AB" & cCell.Row).Interior.Color = 14545386
        End If
         
        If lngCount > 0 Then
            ' Use a count down loop for removing items
            ' from a collection. Otherwise, the loop counter gets
            ' confused and only every other item is removed.
            K = 0
            For I = lngCount To 1 Step -1
             
                ' Get the file name.
                strFile = objAttachments.Item(I).Filename
                 
                ' Combine with the path to the Temp folder.
                strFile = strFolderpath & "\" & strFile
                 
                ' Save the attachment as a file.
                Application.DisplayAlerts = False
                
                On Error Resume Next
                Do
                    objAttachments.Item(I).SaveAsFile strFile
                    
                    If Err <> 0 Then
                        MkDir (Left(strFile, InStrRev(strFile, "\")))
                    Else
                        On Error GoTo 0
                    End If
                Loop Until Err = 0
                
                        
                '---> Insert data in coresponding cells
                Do Until WS.Cells(cCell.Row, K + 5) = ""
                    If K + 6 = 9 Then
                        '---> Copy Insert the new row and contine in Cell E
                        WS.Cells(cCell.Row, K + 5).EntireRow.Copy
                        WS.Cells(cCell.Row, K + 5).EntireRow.Insert
                        WS.Range("E" & cCell.Row & ":H" & cCell.Row).ClearContents
                        K = -1
                    End If
                    K = K + 1
                Loop
                WS.Range("A" & cCell.Row) = objMsg.ReceivedTime
                WS.Range("D" & cCell.Row) = objMsg.SenderEmailAddress
                
                WS.Range(WS.Cells(cCell.Row, K + 5), WS.Cells(cCell.Row, K + 5)).Formula = "=hyperlink(" & Chr(34) & strFile & Chr(34) & "," & Chr(34) & Right(strFile, Len(strFile) - InStrRev(strFile, "\")) & Chr(34) & ")"
                
                FileExt = LCase(Right(strFile, Len(strFile) - InStrRev(LCase(strFile), ".", Len(strFile))))
                
                '---> Check to See if Valid Excel File
                If InStr(1, FileExt, "xls") <> 0 Or InStr(1, FileExt, "xlsm") <> 0 Or InStr(1, FileExt, "xltx") <> 0 Or InStr(1, FileExt, "xlsx") <> 0 Then
                    '---> Open Workbook
                    Application.DisplayAlerts = False
                    Application.ScreenUpdating = False
        
                    Set WB = Workbooks.Open(strFile)
                    Set WSAttach = WB.ActiveSheet
                                
                    '---> Test to see if Valid CC File
                    'If WSAttach.Range("P1") <> "" Then
                    If WSAttach.Range("A1") = "First Name" And WSAttach.Range("B1") = "Last Name" And WSAttach.Range("O1") = "Email Address" Then
                        '---> We are Dealing with Horizontal Spreadsheet
                        '     Assign Col A to Col C as First Name
                        '     Assign Col B to Col B as Last Name
                        WS.Range("C" & cCell.Row) = WSAttach.Range("A2")
                        WS.Range("B" & cCell.Row) = WSAttach.Range("B2")
                        
                        '---> Check if Same Email or Diffrent
                        If WS.Range("D" & cCell.Row) <> WSAttach.Range("O2") Then
                            WS.Range("D" & cCell.Row) = WS.Range("D" & cCell.Row) & " / " & WSAttach.Range("O2")
                        End If
                        
                        '---> Depending on Value of Col P affect Col T
                        If WSAttach.Range("P1") = "Card Number" Then
                            WS.Range("T" & cCell.Row).NumberFormat = "Text"
                            WS.Range("T" & cCell.Row) = WSAttach.Range("P2")
                        Else
                            WS.Range("T" & cCell.Row) = "Not Yet Assigned"
                        End If
                    Else
                        '---> We are Dealing with Vertical Spreadsheet
                        '     Assign B1 to Col C as First Name
                        '     Assign B2 to Col B as Last Name
                        '     Col T = 'Not Yet Assigned'
                        WS.Range("B" & cCell.Row) = WSAttach.Range("B2")
                        WS.Range("C" & cCell.Row) = WSAttach.Range("B1")
                        WS.Range("T" & cCell.Row) = "Not Yet Assigned"
                        
                        '---> Check if Same Email or Diffrent
                        If WS.Range("D" & cCell.Row) <> WSAttach.Range("B15") Then
                            WS.Range("D" & cCell.Row) = WS.Range("D" & cCell.Row) & " / " & WSAttach.Range("B15")
                        End If
                        
                    End If
                
                    '---> Close Workbook
                    WB.Close SaveChanges:=False
                    Set WSAttach = Nothing
                    Set WB = Nothing
        
                    Application.DisplayAlerts = False
                    Application.ScreenUpdating = False
        
                
                Else
                
                    '---> Check to see if Valid .csv file
                    If InStr(1, FileExt, "csv") <> 0 Then
                        '---> Open Workbook
                        Application.DisplayAlerts = False
                        Application.ScreenUpdating = False
            
                        Open strFile For Input As #1
                        
                        '---> Read the Header
                        Do While Not EOF(1)
                            Line Input #1, sFile
                            
                            '---> Split the File by Line
                            sLine = Split(sFile, Chr(10))
                            
                            If UBound(sLine) = 0 Then
                                lTo = 0
                            Else
                                lTo = 1
                            End If
                            For L = 0 To UBound(sLine) - lTo
                                sFields = Split(sLine(L), ",")
                                
                                '---> Test to see if Valid File
                                If L = 0 And InStr(1, sFields(0), "First Name") <> 0 And InStr(1, sFields(1), "Last Name") <> 0 And InStr(1, sFields(7), "Email Address") <> 0 Then
                                    
                                Else
                                    'Line Input #1, sLine
                                    sFields = Split(sLine(L), ",")
                                    
                                    '---> Strip quotes prior affecting
                                    X = ""
                                    For J = 1 To Len(sFields(0))
                                        If Mid(sFields(0), J, 1) <> Chr(34) Then
                                            X = X & Mid(sFields(0), J, 1)
                                        End If
                                    Next J
                                    sFields(0) = X
                                    
                                    X = ""
                                    For J = 1 To Len(sFields(1))
                                        If Mid(sFields(1), J, 1) <> Chr(34) Then
                                            X = X & Mid(sFields(1), J, 1)
                                        End If
                                    Next J
                                    sFields(1) = X
                                    
                                    WS.Range("C" & cCell.Row) = sFields(0)
                                    WS.Range("B" & cCell.Row) = sFields(1)
                                    
                                    '---> Check if Same Email or Diffrent
                                    If WS.Range("D" & cCell.Row) <> sFields(7) Then
                                        WS.Range("D" & cCell.Row) = WS.Range("D" & cCell.Row) & " / " & sFields(7)
                                    End If
                                End If
                                
                            Next L
                        Loop
                        
                        '---> Close the File
                        Close #1
                        Application.DisplayAlerts = False
                        Application.ScreenUpdating = False
                    End If
                    
                End If
                
                
            Next I
            
            '---> Check after all Attachements if Still Col T Empty
            '     then update with Not Yet Assigned.
            '     to ensure Col T always Updated with value
            If WS.Range("T" & cCell.Row) = "" Then
                WS.Range("T" & cCell.Row) = "Not Yet Assigned"
            End If
            
        Else
            '---> Update Email, Date, CC Even if no attachements
            WS.Range("A" & cCell.Row) = objMsg.ReceivedTime
            WS.Range("D" & cCell.Row) = objMsg.SenderEmailAddress
            WS.Range("T" & cCell.Row) = "Not Yet Assigned"
        End If
        
        '---> Move ActiveCell 1 row
        WS.Cells(cCell.Row + 1, 1).Select
        
    Next objMsg

Application.DisplayAlerts = True
Application.ScreenUpdating = True
DoEvents
MsgBox (lngCount & " Attachments were saved on C drive")


ExitSub:
 
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
Exit Sub

ErrHandler:
X = MsgBox("This Routine will Exit due to following Error:" & Chr(10) & Chr(10) & Error(Err), vbCritical)
GoTo ExitSub


End Sub

Open in new window


4) SAVE and Exit the workbook
5) Open it and try it with all kind of attachments.
0
 

Author Comment

by:JaseSt
ID: 39233868
gowflow,

Tried the above code and it brought in a value from the csv file to Col D and inserted "/ Malta" and not the email address. Please see the attached. (It has portions of the sensitive values blotted out.)12
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39233967
Easy
the Email address is at the 8th field meaning if you look at the header First name, Last Name .... Email Adrress
each value is separated by a comma ',' reason why the file is CSV (Comma separated value) so if you count you find out that Email Address is the 8th value so the data at the 8th value should correspond to the email address it happens so that in the sample that you posted the email address is at the 9th value as in the 8th value you have an empty you can see 2 commas ',,' which count for a position.

Don't know if this is due to editing this file or it came like this at the first place. All other files should be at 8th position.

gowflow
0
 

Author Comment

by:JaseSt
ID: 39234298
Didn't edit the file. Don't know why it changed. The csv file is created from a form.

Maybe your function should not look for the 8th value but for the @ sign?
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39234325
can you please check several emails and revert with how many are correct how many not ?
gowflow
0
 

Author Comment

by:JaseSt
ID: 39234345
for one the email was the 7th field,
two others it was the 8th

but here's the thing. this is an order form. while it will always be sent to me as a csv (from the online order form) the developers could add another field in there some day, and maybe they already did, so basing the location of the email address by position might not be the best option.
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39234646
ok I see. Are we at least sure about First and Last name that they will remain on position 1 and 2  ?

Also what I don't get is why the Header is not in sequence with the Data. I can very much understand that it will not remain at same position but at least if Email Address comes in at position 10 in the header it is only normal to have its corresponding data comes in at position 10 also here in the example you posted they are phased out. Could you get clarification on this.

I have no problem to look for Email address and where it sees it to use that index to find its corresponding data. provided they are in sequence.

I do not like much the idea of looking for @ as you may have this thrown somewhere in the address or as a comment or another place it is no guarantee that it will be an email address.

The best is to look for the header Email Address and act accordingly. This also now confirm to me that if you have people developing form then automatically it is something taken into consideration and what you got is simply a small error at a model that is not finalized.
gowflow
0
 

Author Comment

by:JaseSt
ID: 39234666
I would think so and if they ever change that, I'll ask them to change it back so that they are.
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39234758
Check out this version. Provided Header are in sequence with details there should not be a problem !!! I hope.

1) Make a copy of your latest file and give it a new name
2) goto VBA and select Saveattachements sub and delete it.
3) Copy paste the below code after any End Sub


Public Sub SaveAttachments()
On Error GoTo ErrHandler

Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim I As Long, J As Long, K As Long, L As Long, lTo As Long, KK As Long
Dim lngCount As Long
Dim LastRow As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim cCell As Range
Dim WS As Worksheet
Dim FileExt As String
Dim AttachRange As Range
Dim WB As Workbook
Dim WSAttach As Worksheet
Dim X, sFields, sLine
Dim ValidFile As Boolean
Dim sFile As String

    Set WS = ActiveSheet
        
    ' Get the path to your My Documents folder
    strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
    'On Error Resume Next
 
    ' Instantiate an Outlook Application object.
    Set objOL = CreateObject("Outlook.Application")
 
    ' Get the collection of selected objects.
    Set objSelection = objOL.ActiveExplorer.Selection
    'Set objSelection = objOL.GetNamespace("MAPI").Folders("CM Template")
    ' The attachment folder needs to exist
    ' You can change this to another folder name of your choice
 
    ' Set the Attachment folder to be this specific path as per Jaset request on Apr 29, 2013
    strFolderpath = strFolderpath & "\OLAttachments"
    'strFolderpath = "C:\Users\Michael\Sovereign Archives"
    
    ' Check each selected item for attachments.
    For Each objMsg In objSelection
 
        Set objAttachments = objMsg.Attachments
        lngCount = objAttachments.Count
         
        '---> Choose the color of the row
        Set cCell = ActiveCell
        LastRow = cCell.Row + 1
        Do
            '---> Locate the cell color of the last row above the current one
            LastRow = LastRow - 1
            LastRow = WS.Range("A" & LastRow).End(xlUp).Row
            
        Loop Until WS.Range("A" & LastRow).Interior.Color <> 16777215 Or LastRow = 1
        
        '---> Color the new row based on the results
        If WS.Range("A" & LastRow).Interior.Color = 14545386 Then
            WS.Range("A" & cCell.Row & ":AB" & cCell.Row).Interior.Color = 10147522
        Else
            WS.Range("A" & cCell.Row & ":AB" & cCell.Row).Interior.Color = 14545386
        End If
         
        If lngCount > 0 Then
            ' Use a count down loop for removing items
            ' from a collection. Otherwise, the loop counter gets
            ' confused and only every other item is removed.
            K = 0
            For I = lngCount To 1 Step -1
             
                ' Get the file name.
                strFile = objAttachments.Item(I).Filename
                 
                ' Combine with the path to the Temp folder.
                strFile = strFolderpath & "\" & strFile
                 
                ' Save the attachment as a file.
                Application.DisplayAlerts = False
                
                On Error Resume Next
                Do
                    objAttachments.Item(I).SaveAsFile strFile
                    
                    If Err <> 0 Then
                        MkDir (Left(strFile, InStrRev(strFile, "\")))
                    Else
                        On Error GoTo 0
                    End If
                Loop Until Err = 0
                
                        
                '---> Insert data in coresponding cells
                Do Until WS.Cells(cCell.Row, K + 5) = ""
                    If K + 6 = 9 Then
                        '---> Copy Insert the new row and contine in Cell E
                        WS.Cells(cCell.Row, K + 5).EntireRow.Copy
                        WS.Cells(cCell.Row, K + 5).EntireRow.Insert
                        WS.Range("E" & cCell.Row & ":H" & cCell.Row).ClearContents
                        K = -1
                    End If
                    K = K + 1
                Loop
                WS.Range("A" & cCell.Row) = objMsg.ReceivedTime
                WS.Range("D" & cCell.Row) = objMsg.SenderEmailAddress
                
                WS.Range(WS.Cells(cCell.Row, K + 5), WS.Cells(cCell.Row, K + 5)).Formula = "=hyperlink(" & Chr(34) & strFile & Chr(34) & "," & Chr(34) & Right(strFile, Len(strFile) - InStrRev(strFile, "\")) & Chr(34) & ")"
                
                FileExt = LCase(Right(strFile, Len(strFile) - InStrRev(LCase(strFile), ".", Len(strFile))))
                
                '---> Check to See if Valid Excel File
                If InStr(1, FileExt, "xls") <> 0 Or InStr(1, FileExt, "xlsm") <> 0 Or InStr(1, FileExt, "xltx") <> 0 Or InStr(1, FileExt, "xlsx") <> 0 Then
                    '---> Open Workbook
                    Application.DisplayAlerts = False
                    Application.ScreenUpdating = False
        
                    Set WB = Workbooks.Open(strFile)
                    Set WSAttach = WB.ActiveSheet
                                
                    '---> Test to see if Valid CC File
                    'If WSAttach.Range("P1") <> "" Then
                    If WSAttach.Range("A1") = "First Name" And WSAttach.Range("B1") = "Last Name" And WSAttach.Range("O1") = "Email Address" Then
                        '---> We are Dealing with Horizontal Spreadsheet
                        '     Assign Col A to Col C as First Name
                        '     Assign Col B to Col B as Last Name
                        WS.Range("C" & cCell.Row) = WSAttach.Range("A2")
                        WS.Range("B" & cCell.Row) = WSAttach.Range("B2")
                        
                        '---> Check if Same Email or Diffrent
                        If WS.Range("D" & cCell.Row) <> WSAttach.Range("O2") Then
                            WS.Range("D" & cCell.Row) = WS.Range("D" & cCell.Row) & " / " & WSAttach.Range("O2")
                        End If
                        
                        '---> Depending on Value of Col P affect Col T
                        If WSAttach.Range("P1") = "Card Number" Then
                            WS.Range("T" & cCell.Row).NumberFormat = "Text"
                            WS.Range("T" & cCell.Row) = WSAttach.Range("P2")
                        Else
                            WS.Range("T" & cCell.Row) = "Not Yet Assigned"
                        End If
                    Else
                        '---> We are Dealing with Vertical Spreadsheet
                        '     Assign B1 to Col C as First Name
                        '     Assign B2 to Col B as Last Name
                        '     Col T = 'Not Yet Assigned'
                        WS.Range("B" & cCell.Row) = WSAttach.Range("B2")
                        WS.Range("C" & cCell.Row) = WSAttach.Range("B1")
                        WS.Range("T" & cCell.Row) = "Not Yet Assigned"
                        
                        '---> Check if Same Email or Diffrent
                        If WS.Range("D" & cCell.Row) <> WSAttach.Range("B15") Then
                            WS.Range("D" & cCell.Row) = WS.Range("D" & cCell.Row) & " / " & WSAttach.Range("B15")
                        End If
                        
                    End If
                
                    '---> Close Workbook
                    WB.Close SaveChanges:=False
                    Set WSAttach = Nothing
                    Set WB = Nothing
        
                    Application.DisplayAlerts = False
                    Application.ScreenUpdating = False
        
                
                Else
                
                    '---> Check to see if Valid .csv file
                    If InStr(1, FileExt, "csv") <> 0 Then
                        '---> Open Workbook
                        Application.DisplayAlerts = False
                        Application.ScreenUpdating = False
            
                        Open strFile For Input As #1
                        KK = 99
                        
                        '---> Read the Header
                        Do While Not EOF(1)
                            Line Input #1, sFile
                            
                            '---> Split the File by Line
                            sLine = Split(sFile, Chr(10))
                                
                            If UBound(sLine) = 0 Then
                                lTo = 0
                            Else
                                lTo = 1
                            End If
                            
                            For L = 0 To UBound(sLine) - lTo
                                sFields = Split(sLine(L), ",")
                                
                                '---> Look for Email Address position
                                If L = 0 And KK = 99 Then
                                    For KK = 0 To UBound(sFields)
                                        If InStr(1, sFields(KK), "Email Address") <> 0 Then Exit For
                                    Next KK
                                End If
                                
                                '---> Test to see if Valid File
                                If L = 0 And InStr(1, sFields(0), "First Name") <> 0 And InStr(1, sFields(1), "Last Name") <> 0 And InStr(1, sFields(KK), "Email Address") <> 0 Then
                                    
                                Else
                                    'Line Input #1, sLine
                                    sFields = Split(sLine(L), ",")
                                    
                                    '---> Strip quotes prior affecting
                                    X = ""
                                    For J = 1 To Len(sFields(0))
                                        If Mid(sFields(0), J, 1) <> Chr(34) Then
                                            X = X & Mid(sFields(0), J, 1)
                                        End If
                                    Next J
                                    sFields(0) = X
                                    
                                    X = ""
                                    For J = 1 To Len(sFields(1))
                                        If Mid(sFields(1), J, 1) <> Chr(34) Then
                                            X = X & Mid(sFields(1), J, 1)
                                        End If
                                    Next J
                                    sFields(1) = X
                                    
                                    WS.Range("C" & cCell.Row) = sFields(0)
                                    WS.Range("B" & cCell.Row) = sFields(1)
                                    
                                    '---> Check if Same Email or Diffrent
                                    If WS.Range("D" & cCell.Row) <> sFields(KK) Then
                                        WS.Range("D" & cCell.Row) = WS.Range("D" & cCell.Row) & " / " & sFields(KK)
                                    End If
                                End If
                                
                            Next L
                        Loop
                        
                        '---> Close the File
                        Close #1
                        Application.DisplayAlerts = False
                        Application.ScreenUpdating = False
                    End If
                    
                End If
                
                
            Next I
            
            '---> Check after all Attachements if Still Col T Empty
            '     then update with Not Yet Assigned.
            '     to ensure Col T always Updated with value
            If WS.Range("T" & cCell.Row) = "" Then
                WS.Range("T" & cCell.Row) = "Not Yet Assigned"
            End If
            
        Else
            '---> Update Email, Date, CC Even if no attachements
            WS.Range("A" & cCell.Row) = objMsg.ReceivedTime
            WS.Range("D" & cCell.Row) = objMsg.SenderEmailAddress
            WS.Range("T" & cCell.Row) = "Not Yet Assigned"
        End If
        
        '---> Move ActiveCell 1 row
        WS.Cells(cCell.Row + 1, 1).Select
        
    Next objMsg

Application.DisplayAlerts = True
Application.ScreenUpdating = True
DoEvents
MsgBox (lngCount & " Attachments were saved on C drive")


ExitSub:
 
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
Exit Sub

ErrHandler:
X = MsgBox("This Routine will Exit due to following Error:" & Chr(10) & Chr(10) & Error(Err), vbCritical)
GoTo ExitSub


End Sub

Open in new window


4) SAVE and Exit
5) Try it out with all kind of files.

gowflow
0
 

Author Comment

by:JaseSt
ID: 39234777
tried it out. same result as before. Came back as Malta
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39235093
Well for this one I told you it is not in sequence I cannot do anything !!!! count them and you will see the header is at position 8 and the data at position 9 !!!!!
In the new macro the position of Email Address is not fix it will lookup the header and when it find it it will use the same index to find its data being at 9 or 8 or 10 or 15 or 100 whatever it find it apply the data. So here it found the header at 8 and the data for 8 is Malta and 9 is the email address !!!! tough luck.

gowflow
0
 

Author Comment

by:JaseSt
ID: 39235176
can't you just look for the @ sign to identify the email address?
0
 
LVL 29

Accepted Solution

by:
gowflow earned 500 total points
ID: 39235544
I do not like that. In my language it is called patching !!! but anyhow try this and let me know.

Public Sub SaveAttachments()
On Error GoTo ErrHandler

Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim I As Long, J As Long, K As Long, L As Long, lTo As Long, KK As Long
Dim lngCount As Long
Dim LastRow As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim cCell As Range
Dim WS As Worksheet
Dim FileExt As String
Dim AttachRange As Range
Dim WB As Workbook
Dim WSAttach As Worksheet
Dim X, sFields, sLine
Dim ValidFile As Boolean
Dim sFile As String

    Set WS = ActiveSheet
        
    ' Get the path to your My Documents folder
    strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
    'On Error Resume Next
 
    ' Instantiate an Outlook Application object.
    Set objOL = CreateObject("Outlook.Application")
 
    ' Get the collection of selected objects.
    Set objSelection = objOL.ActiveExplorer.Selection
    'Set objSelection = objOL.GetNamespace("MAPI").Folders("CM Template")
    ' The attachment folder needs to exist
    ' You can change this to another folder name of your choice
 
    ' Set the Attachment folder to be this specific path as per Jaset request on Apr 29, 2013
    strFolderpath = strFolderpath & "\OLAttachments"
    'strFolderpath = "C:\Users\Michael\Sovereign Archives"
    
    ' Check each selected item for attachments.
    For Each objMsg In objSelection
 
        Set objAttachments = objMsg.Attachments
        lngCount = objAttachments.Count
         
        '---> Choose the color of the row
        Set cCell = ActiveCell
        LastRow = cCell.Row + 1
        Do
            '---> Locate the cell color of the last row above the current one
            LastRow = LastRow - 1
            LastRow = WS.Range("A" & LastRow).End(xlUp).Row
            
        Loop Until WS.Range("A" & LastRow).Interior.Color <> 16777215 Or LastRow = 1
        
        '---> Color the new row based on the results
        If WS.Range("A" & LastRow).Interior.Color = 14545386 Then
            WS.Range("A" & cCell.Row & ":AB" & cCell.Row).Interior.Color = 10147522
        Else
            WS.Range("A" & cCell.Row & ":AB" & cCell.Row).Interior.Color = 14545386
        End If
         
        If lngCount > 0 Then
            ' Use a count down loop for removing items
            ' from a collection. Otherwise, the loop counter gets
            ' confused and only every other item is removed.
            K = 0
            For I = lngCount To 1 Step -1
             
                ' Get the file name.
                strFile = objAttachments.Item(I).Filename
                 
                ' Combine with the path to the Temp folder.
                strFile = strFolderpath & "\" & strFile
                 
                ' Save the attachment as a file.
                Application.DisplayAlerts = False
                
                On Error Resume Next
                Do
                    objAttachments.Item(I).SaveAsFile strFile
                    
                    If Err <> 0 Then
                        MkDir (Left(strFile, InStrRev(strFile, "\")))
                    Else
                        On Error GoTo 0
                    End If
                Loop Until Err = 0
                
                        
                '---> Insert data in coresponding cells
                Do Until WS.Cells(cCell.Row, K + 5) = ""
                    If K + 6 = 9 Then
                        '---> Copy Insert the new row and contine in Cell E
                        WS.Cells(cCell.Row, K + 5).EntireRow.Copy
                        WS.Cells(cCell.Row, K + 5).EntireRow.Insert
                        WS.Range("E" & cCell.Row & ":H" & cCell.Row).ClearContents
                        K = -1
                    End If
                    K = K + 1
                Loop
                WS.Range("A" & cCell.Row) = objMsg.ReceivedTime
                WS.Range("D" & cCell.Row) = objMsg.SenderEmailAddress
                
                WS.Range(WS.Cells(cCell.Row, K + 5), WS.Cells(cCell.Row, K + 5)).Formula = "=hyperlink(" & Chr(34) & strFile & Chr(34) & "," & Chr(34) & Right(strFile, Len(strFile) - InStrRev(strFile, "\")) & Chr(34) & ")"
                
                FileExt = LCase(Right(strFile, Len(strFile) - InStrRev(LCase(strFile), ".", Len(strFile))))
                
                '---> Check to See if Valid Excel File
                If InStr(1, FileExt, "xls") <> 0 Or InStr(1, FileExt, "xlsm") <> 0 Or InStr(1, FileExt, "xltx") <> 0 Or InStr(1, FileExt, "xlsx") <> 0 Then
                    '---> Open Workbook
                    Application.DisplayAlerts = False
                    Application.ScreenUpdating = False
        
                    Set WB = Workbooks.Open(strFile)
                    Set WSAttach = WB.ActiveSheet
                                
                    '---> Test to see if Valid CC File
                    'If WSAttach.Range("P1") <> "" Then
                    If WSAttach.Range("A1") = "First Name" And WSAttach.Range("B1") = "Last Name" And WSAttach.Range("O1") = "Email Address" Then
                        '---> We are Dealing with Horizontal Spreadsheet
                        '     Assign Col A to Col C as First Name
                        '     Assign Col B to Col B as Last Name
                        WS.Range("C" & cCell.Row) = WSAttach.Range("A2")
                        WS.Range("B" & cCell.Row) = WSAttach.Range("B2")
                        
                        '---> Check if Same Email or Diffrent
                        If WS.Range("D" & cCell.Row) <> WSAttach.Range("O2") Then
                            WS.Range("D" & cCell.Row) = WS.Range("D" & cCell.Row) & " / " & WSAttach.Range("O2")
                        End If
                        
                        '---> Depending on Value of Col P affect Col T
                        If WSAttach.Range("P1") = "Card Number" Then
                            WS.Range("T" & cCell.Row).NumberFormat = "Text"
                            WS.Range("T" & cCell.Row) = WSAttach.Range("P2")
                        Else
                            WS.Range("T" & cCell.Row) = "Not Yet Assigned"
                        End If
                    Else
                        '---> We are Dealing with Vertical Spreadsheet
                        '     Assign B1 to Col C as First Name
                        '     Assign B2 to Col B as Last Name
                        '     Col T = 'Not Yet Assigned'
                        WS.Range("B" & cCell.Row) = WSAttach.Range("B2")
                        WS.Range("C" & cCell.Row) = WSAttach.Range("B1")
                        WS.Range("T" & cCell.Row) = "Not Yet Assigned"
                        
                        '---> Check if Same Email or Diffrent
                        If WS.Range("D" & cCell.Row) <> WSAttach.Range("B15") Then
                            WS.Range("D" & cCell.Row) = WS.Range("D" & cCell.Row) & " / " & WSAttach.Range("B15")
                        End If
                        
                    End If
                
                    '---> Close Workbook
                    WB.Close SaveChanges:=False
                    Set WSAttach = Nothing
                    Set WB = Nothing
        
                    Application.DisplayAlerts = False
                    Application.ScreenUpdating = False
        
                
                Else
                
                    '---> Check to see if Valid .csv file
                    If InStr(1, FileExt, "csv") <> 0 Then
                        '---> Open Workbook
                        Application.DisplayAlerts = False
                        Application.ScreenUpdating = False
            
                        Open strFile For Input As #1
                        KK = 99
                        
                        '---> Read the Header
                        Do While Not EOF(1)
                            Line Input #1, sFile
                            
                            '---> Split the File by Line
                            sLine = Split(sFile, Chr(10))
                                
                            If UBound(sLine) = 0 Then
                                lTo = 0
                            Else
                                lTo = 1
                            End If
                            
                            For L = 0 To UBound(sLine) - lTo
                                sFields = Split(sLine(L), ",")
                                
                                '---> Look for Email Address position
                                If L = 0 And KK = 99 Then
                                    For KK = 0 To UBound(sFields)
                                        If InStr(1, sFields(KK), "Email Address") <> 0 Then Exit For
                                    Next KK
                                Else
                                    If InStr(1, sFields(KK), "@") = 0 Then
                                        For KK = 0 To UBound(sFields)
                                            If InStr(1, sFields(KK), "@") <> 0 Then Exit For
                                        Next KK
                                    End If
                                End If
                                
                                '---> Test to see if Valid File
                                If L = 0 And InStr(1, sFields(0), "First Name") <> 0 And InStr(1, sFields(1), "Last Name") <> 0 And InStr(1, sFields(KK), "Email Address") <> 0 Then
                                    
                                Else
                                    'Line Input #1, sLine
                                    sFields = Split(sLine(L), ",")
                                    
                                    '---> Strip quotes prior affecting
                                    X = ""
                                    For J = 1 To Len(sFields(0))
                                        If Mid(sFields(0), J, 1) <> Chr(34) Then
                                            X = X & Mid(sFields(0), J, 1)
                                        End If
                                    Next J
                                    sFields(0) = X
                                    
                                    X = ""
                                    For J = 1 To Len(sFields(1))
                                        If Mid(sFields(1), J, 1) <> Chr(34) Then
                                            X = X & Mid(sFields(1), J, 1)
                                        End If
                                    Next J
                                    sFields(1) = X
                                    
                                    WS.Range("C" & cCell.Row) = sFields(0)
                                    WS.Range("B" & cCell.Row) = sFields(1)
                                    
                                    '---> Check if Same Email or Diffrent
                                    If WS.Range("D" & cCell.Row) <> sFields(KK) Then
                                        WS.Range("D" & cCell.Row) = WS.Range("D" & cCell.Row) & " / " & sFields(KK)
                                    End If
                                End If
                                
                            Next L
                        Loop
                        
                        '---> Close the File
                        Close #1
                        Application.DisplayAlerts = False
                        Application.ScreenUpdating = False
                    End If
                    
                End If
                
                
            Next I
            
            '---> Check after all Attachements if Still Col T Empty
            '     then update with Not Yet Assigned.
            '     to ensure Col T always Updated with value
            If WS.Range("T" & cCell.Row) = "" Then
                WS.Range("T" & cCell.Row) = "Not Yet Assigned"
            End If
            
        Else
            '---> Update Email, Date, CC Even if no attachements
            WS.Range("A" & cCell.Row) = objMsg.ReceivedTime
            WS.Range("D" & cCell.Row) = objMsg.SenderEmailAddress
            WS.Range("T" & cCell.Row) = "Not Yet Assigned"
        End If
        
        '---> Move ActiveCell 1 row
        WS.Cells(cCell.Row + 1, 1).Select
        
    Next objMsg

Application.DisplayAlerts = True
Application.ScreenUpdating = True
DoEvents
MsgBox (lngCount & " Attachments were saved on C drive")


ExitSub:
 
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
Exit Sub

ErrHandler:
X = MsgBox("This Routine will Exit due to following Error:" & Chr(10) & Chr(10) & Error(Err), vbCritical)
GoTo ExitSub


End Sub

Open in new window



Pls try it inside out with all kind of files xls horizontal vertical csv all types.
gowflow
0
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 

Author Closing Comment

by:JaseSt
ID: 39236799
Yes, that worked for various emails I tried. Thanks again, gowflow. You're a master!
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39236801
:( ... am a Sage !!! :)
0
 

Author Comment

by:JaseSt
ID: 39237436
Well if Sage is above Master, then yes, you're a Sage.
And, we've got more cool things to do with this spreadsheet. Ready?
0
 

Author Comment

by:JaseSt
ID: 39237501
oops, it didn't extract the email address from an xls form. it put in the / but not the email address. the email address was in Col O with the header Email Address
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39237654
pls post it and will look at it. It usually pick O2 as O1 has Email Address in there
gowflow
0
 

Author Comment

by:JaseSt
ID: 39237875
attached is screenshot of offending file and emailxls file screenshot
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39240920
We are guessing here as you did not attach the file

Make sure that the following  are exactly like this no more space or any different caps

A1 = First Name
B1 = Last Name
O1 = Email Address

if above is ok then look at value in O2 that is supposed to be the email address click on cell O2 and look at the address bar and see what value is there is it the email address or blank ??? although it shows in the cell it could be padded with a line feed character reason why it was not picked up.

Let me know
gowflow
0
 

Author Comment

by:JaseSt
ID: 39241653
the csv file comes in with these col headings and in this order:

First Name      Last Name      Street Address      City      State      Zip Code      Country      Email Address      Contact Number      Country of Citzenship      Date Of Birth      Government ID Number      ID Type      ID Expiry      Mothers Maiden Name

and the function got the email address and inserted it correctly

the xls file has these col headings and in this order:

First Name      Last Name      Street Address      City      County/State      Post Code/ Zip Code      Country      Country of Citzenship      Date Of Birth      Government ID Number      ID Type      ID Expiry      Mothers Maiden Name      Contact Number      Email Address
0
 

Author Comment

by:JaseSt
ID: 39241672
USD-Mastercard-Profile-Sheet.xls

This is the xls file the customer fills out and emails back to me
0
 

Author Comment

by:JaseSt
ID: 39243383
so it seems the xls formatted file is not importing the credit card number to Applicant Status either. A screen shot of one not imported correctly for email address or card number, attached.xls
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39243530
One thing I do not understand is the following.

You said the file attached USD-Mastercard-Profile-Sheet.xls is the file you send and customers fill it and send it back.

Now this file has headers from Col A to Col O Ending with Email Address all subsequent columns are blank.

Then the last snapshot has a file that also have columns after Col O which are
Col P Card Number
Col Q Initial Loading Amount

So how these and when they are added ?? and why they are not added in the initial template to start with ???

gowflow
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39243553
In any case try this version.

1) Make a copy of your latest file and give it a new name
2) goto VBA and select Saveattachements sub and delete it.
3) Copy paste the below code after any End Sub

Public Sub SaveAttachments()
On Error GoTo ErrHandler

Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim I As Long, J As Long, K As Long, L As Long, lTo As Long, KK As Long
Dim lngCount As Long
Dim LastRow As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim cCell As Range
Dim WS As Worksheet
Dim FileExt As String
Dim AttachRange As Range
Dim WB As Workbook
Dim WSAttach As Worksheet
Dim X, sFields, sLine
Dim ValidFile As Boolean
Dim sFile As String

    Set WS = ActiveSheet
        
    ' Get the path to your My Documents folder
    strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
    'On Error Resume Next
 
    ' Instantiate an Outlook Application object.
    Set objOL = CreateObject("Outlook.Application")
 
    ' Get the collection of selected objects.
    Set objSelection = objOL.ActiveExplorer.Selection
    'Set objSelection = objOL.GetNamespace("MAPI").Folders("CM Template")
    ' The attachment folder needs to exist
    ' You can change this to another folder name of your choice
 
    ' Set the Attachment folder to be this specific path as per Jaset request on Apr 29, 2013
    strFolderpath = strFolderpath & "\OLAttachments"
    'strFolderpath = "C:\Users\Michael\Sovereign Archives"
    
    ' Check each selected item for attachments.
    For Each objMsg In objSelection
 
        Set objAttachments = objMsg.Attachments
        lngCount = objAttachments.Count
         
        '---> Choose the color of the row
        Set cCell = ActiveCell
        LastRow = cCell.Row + 1
        Do
            '---> Locate the cell color of the last row above the current one
            LastRow = LastRow - 1
            LastRow = WS.Range("A" & LastRow).End(xlUp).Row
            
        Loop Until WS.Range("A" & LastRow).Interior.Color <> 16777215 Or LastRow = 1
        
        '---> Color the new row based on the results
        If WS.Range("A" & LastRow).Interior.Color = 14545386 Then
            WS.Range("A" & cCell.Row & ":AB" & cCell.Row).Interior.Color = 10147522
        Else
            WS.Range("A" & cCell.Row & ":AB" & cCell.Row).Interior.Color = 14545386
        End If
         
        If lngCount > 0 Then
            ' Use a count down loop for removing items
            ' from a collection. Otherwise, the loop counter gets
            ' confused and only every other item is removed.
            K = 0
            For I = lngCount To 1 Step -1
             
                ' Get the file name.
                strFile = objAttachments.Item(I).Filename
                 
                ' Combine with the path to the Temp folder.
                strFile = strFolderpath & "\" & strFile
                 
                ' Save the attachment as a file.
                Application.DisplayAlerts = False
                
                On Error Resume Next
                Do
                    objAttachments.Item(I).SaveAsFile strFile
                    
                    If Err <> 0 Then
                        MkDir (Left(strFile, InStrRev(strFile, "\")))
                    Else
                        On Error GoTo 0
                    End If
                Loop Until Err = 0
                
                        
                '---> Insert data in coresponding cells
                Do Until WS.Cells(cCell.Row, K + 5) = ""
                    If K + 6 = 9 Then
                        '---> Copy Insert the new row and contine in Cell E
                        WS.Cells(cCell.Row, K + 5).EntireRow.Copy
                        WS.Cells(cCell.Row, K + 5).EntireRow.Insert
                        WS.Range("E" & cCell.Row & ":H" & cCell.Row).ClearContents
                        K = -1
                    End If
                    K = K + 1
                Loop
                WS.Range("A" & cCell.Row) = objMsg.ReceivedTime
                WS.Range("D" & cCell.Row) = objMsg.SenderEmailAddress
                
                WS.Range(WS.Cells(cCell.Row, K + 5), WS.Cells(cCell.Row, K + 5)).Formula = "=hyperlink(" & Chr(34) & strFile & Chr(34) & "," & Chr(34) & Right(strFile, Len(strFile) - InStrRev(strFile, "\")) & Chr(34) & ")"
                
                FileExt = LCase(Right(strFile, Len(strFile) - InStrRev(LCase(strFile), ".", Len(strFile))))
                
                '---> Check to See if Valid Excel File
                If InStr(1, LCase(FileExt), "xls") <> 0 Or InStr(1, LCase(FileExt), "xlsm") <> 0 Or InStr(1, LCase(FileExt), "xltx") <> 0 Or InStr(1, LCase(FileExt), "xlsx") <> 0 Then
                    '---> Open Workbook
                    Application.DisplayAlerts = False
                    Application.ScreenUpdating = False
        
                    Set WB = Workbooks.Open(strFile)
                    Set WSAttach = WB.ActiveSheet
                                
                    '---> Test to see if Valid CC File
                    'If WSAttach.Range("P1") <> "" Then
                    If InStr(1, LCase(WSAttach.Range("A1")), "first name") <> 0 And InStr(1, LCase(WSAttach.Range("B1")), "last name") <> 0 And InStr(1, LCase(WSAttach.Range("O1")), "email address") <> 0 Then
                        '---> We are Dealing with Horizontal Spreadsheet
                        '     Assign Col A to Col C as First Name
                        '     Assign Col B to Col B as Last Name
                        WS.Range("C" & cCell.Row) = WSAttach.Range("A2")
                        WS.Range("B" & cCell.Row) = WSAttach.Range("B2")
                        
                        '---> Check if Same Email or Diffrent
                        If WS.Range("D" & cCell.Row) <> WSAttach.Range("O2") Then
                            WS.Range("D" & cCell.Row) = WS.Range("D" & cCell.Row) & " / " & WSAttach.Range("O2")
                        End If
                        
                        '---> Depending on Value of Col P affect Col T
                        If InStr(1, LCase(WSAttach.Range("P1")), "card number") <> 0 Then
                            WS.Range("T" & cCell.Row).NumberFormat = "Text"
                            WS.Range("T" & cCell.Row) = WSAttach.Range("P2")
                        Else
                            WS.Range("T" & cCell.Row) = "Not Yet Assigned"
                        End If
                    Else
                        '---> We are Dealing with Vertical Spreadsheet
                        '     Assign B1 to Col C as First Name
                        '     Assign B2 to Col B as Last Name
                        '     Col T = 'Not Yet Assigned'
                        WS.Range("B" & cCell.Row) = WSAttach.Range("B2")
                        WS.Range("C" & cCell.Row) = WSAttach.Range("B1")
                        WS.Range("T" & cCell.Row) = "Not Yet Assigned"
                        
                        '---> Check if Same Email or Diffrent
                        If WS.Range("D" & cCell.Row) <> WSAttach.Range("B15") Then
                            WS.Range("D" & cCell.Row) = WS.Range("D" & cCell.Row) & " / " & WSAttach.Range("B15")
                        End If
                        
                    End If
                
                    '---> Close Workbook
                    WB.Close SaveChanges:=False
                    Set WSAttach = Nothing
                    Set WB = Nothing
        
                    Application.DisplayAlerts = False
                    Application.ScreenUpdating = False
        
                
                Else
                
                    '---> Check to see if Valid .csv file
                    If InStr(1, FileExt, "csv") <> 0 Then
                        '---> Open Workbook
                        Application.DisplayAlerts = False
                        Application.ScreenUpdating = False
            
                        Open strFile For Input As #1
                        KK = 99
                        
                        '---> Read the Header
                        Do While Not EOF(1)
                            Line Input #1, sFile
                            
                            '---> Split the File by Line
                            sLine = Split(sFile, Chr(10))
                                
                            If UBound(sLine) = 0 Then
                                lTo = 0
                            Else
                                lTo = 1
                            End If
                            
                            For L = 0 To UBound(sLine) - lTo
                                sFields = Split(sLine(L), ",")
                                
                                '---> Look for Email Address position
                                If L = 0 And KK = 99 Then
                                    For KK = 0 To UBound(sFields)
                                        If InStr(1, sFields(KK), "Email Address") <> 0 Then Exit For
                                    Next KK
                                Else
                                    If InStr(1, sFields(KK), "@") = 0 Then
                                        For KK = 0 To UBound(sFields)
                                            If InStr(1, sFields(KK), "@") <> 0 Then Exit For
                                        Next KK
                                    End If
                                End If
                                
                                '---> Test to see if Valid File
                                If L = 0 And InStr(1, sFields(0), "First Name") <> 0 And InStr(1, sFields(1), "Last Name") <> 0 And InStr(1, sFields(KK), "Email Address") <> 0 Then
                                    
                                Else
                                    'Line Input #1, sLine
                                    sFields = Split(sLine(L), ",")
                                    
                                    '---> Strip quotes prior affecting
                                    X = ""
                                    For J = 1 To Len(sFields(0))
                                        If Mid(sFields(0), J, 1) <> Chr(34) Then
                                            X = X & Mid(sFields(0), J, 1)
                                        End If
                                    Next J
                                    sFields(0) = X
                                    
                                    X = ""
                                    For J = 1 To Len(sFields(1))
                                        If Mid(sFields(1), J, 1) <> Chr(34) Then
                                            X = X & Mid(sFields(1), J, 1)
                                        End If
                                    Next J
                                    sFields(1) = X
                                    
                                    WS.Range("C" & cCell.Row) = sFields(0)
                                    WS.Range("B" & cCell.Row) = sFields(1)
                                    
                                    '---> Check if Same Email or Diffrent
                                    If WS.Range("D" & cCell.Row) <> sFields(KK) Then
                                        WS.Range("D" & cCell.Row) = WS.Range("D" & cCell.Row) & " / " & sFields(KK)
                                    End If
                                End If
                                
                            Next L
                        Loop
                        
                        '---> Close the File
                        Close #1
                        Application.DisplayAlerts = False
                        Application.ScreenUpdating = False
                    End If
                    
                End If
                
                
            Next I
            
            '---> Check after all Attachements if Still Col T Empty
            '     then update with Not Yet Assigned.
            '     to ensure Col T always Updated with value
            If WS.Range("T" & cCell.Row) = "" Then
                WS.Range("T" & cCell.Row) = "Not Yet Assigned"
            End If
            
        Else
            '---> Update Email, Date, CC Even if no attachements
            WS.Range("A" & cCell.Row) = objMsg.ReceivedTime
            WS.Range("D" & cCell.Row) = objMsg.SenderEmailAddress
            WS.Range("T" & cCell.Row) = "Not Yet Assigned"
        End If
        
        '---> Move ActiveCell 1 row
        WS.Cells(cCell.Row + 1, 1).Select
        
    Next objMsg

Application.DisplayAlerts = True
Application.ScreenUpdating = True
DoEvents
MsgBox (lngCount & " Attachments were saved on C drive")


ExitSub:
 
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
Exit Sub

ErrHandler:
X = MsgBox("This Routine will Exit due to following Error:" & Chr(10) & Chr(10) & Error(Err), vbCritical)
GoTo ExitSub


End Sub

Open in new window


4) SAVE and Exit the workbook.
5) open it and give it a try

gowflow
0
 

Author Comment

by:JaseSt
ID: 39244419
fantastic! works perfectly.
Thanks again, gowlfow
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39244441
Are you sure ??? did u try it inside out ??
gowflow
0
 

Author Comment

by:JaseSt
ID: 39244451
tried it on csv and a couple xls files. The only real way is over time when more files come in, but I think you got it covered.
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39244487
ok fine, lets cross fingers !!!
Any other issue pls do not hesitate to post it here.
gowflow
0
 

Author Comment

by:JaseSt
ID: 39244765
0

Featured Post

How to improve team productivity

Quip adds documents, spreadsheets, and tasklists to your Slack experience
- Elevate ideas to Quip docs
- Share Quip docs in Slack
- Get notified of changes to your docs
- Available on iOS/Android/Desktop/Web
- Online/Offline

Join & Write a Comment

Suggested Solutions

Granting full access permission allows users to access mailboxes present in their database. By giving full access permission one can open and read the content of any mailbox but cannot send emails from that mailbox.
Create high volume marketing opportunities using email signatures with these top 10 DOs and DON'Ts of email signature marketing.
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.
To add imagery to an HTML email signature, you have two options available to you. You can either add a logo/image by embedding it directly into the signature or hosting it externally and linking to it. The vast majority of email clients display l…

707 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

15 Experts available now in Live!

Get 1:1 Help Now