Solved

Part 3 to: Import more data into spreadsheet

Posted on 2013-05-20
29
347 Views
Last Modified: 2013-05-30
Continuing from previous referenced question and solution (http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28113301.html):

1. Even if there are no attachments in the email, I still need the email address, date and Not Yet Assigned inserted in appropriate columns of the record for emails that I click the Save Links button on.

2. For all emails I click Save Links for, extract the first and last name from emailed spreadsheet and paste into Applicant Status.

For Horizontal layout that would be Col A - first name - from emailed spreadsheet goes to Col C in Applicant Status and Col B - last name - from emailed spreadsheet goes to Col B in Applicant Status)

For Vertical emailed spreadsheet Cell B1 goes to Col C and Cell B2 goes to Col B.

3. When I input a x value in Cols: N,  P, Q, R and S please have it so the x changes to today's date in the format: mm/dd/year: 05/20/2013
0
Comment
Question by:JaseSt
  • 16
  • 13
29 Comments
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
Let me get point3
You say when you insert 'x' (small x) in any of Col N or P or Q or R or S you want the affected column to take today's date ? Is that what you want ?
Else please clarify.

gowflow
0
 

Author Comment

by:JaseSt
Comment Utility
yes
0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
ok for point 3

Point 1
You mean to have the email, Date, Not Yet Assigned inputed WITHOUT you activating Save Links ??

gowflow
0
 

Author Comment

by:JaseSt
Comment Utility
no, I would have to activate Save Links for it to do its thing.

Some emails come in without any attachments but I still need to have as much data extracted from that email as possible. Thus, the names and email address and date - along with Not Yet Assigned. And I would extract that data only when I click on the Save Links button.
0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
ok clear and here it is:

1) Make a copy of your latest Applicant Status file and gie it a new name.
2) Goto VBA and doubleclick on sheet1 and click on left bottom icon to view 1 sub at a time
3) select the Sub SaveAttachements and delete it.
4) Paste the below code after any En 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, K 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

    Set WS = ActiveSheet
    Set cCell = ActiveCell
    
    ' 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
        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) & ")"
                
                '---> Check to See if Valid Excel File
                FileExt = LCase(Right(strFile, Len(strFile) - InStrRev(LCase(strFile), ".", Len(strFile))))
                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
                        '---> 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")

                        
                        '---> 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"
                    End If
                
                    '---> Close Workbook
                    WB.Close SaveChanges:=False
                    Set WSAttach = Nothing
                    Set WB = Nothing
        
                    Application.DisplayAlerts = False
                    Application.ScreenUpdating = False
        
                
                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
     
    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


5) SAVE the workbook.
6) now from the top left dropdown select Worksheet (still in VBA) and from the right drop down select the Change Event

you should have something like this:
===========
Private Sub Worksheet_Change(ByVal Target As Range)

End Sub
===========

7) Insert the below code between Private ... and End Sub

Dim cCell As Range

For Each cCell In Target
    If (Not Intersect(cCell, Columns("N")) Is Nothing Or _
        Not Intersect(cCell, Columns("P")) Is Nothing Or _
        Not Intersect(cCell, Columns("Q")) Is Nothing Or _
        Not Intersect(cCell, Columns("R")) Is Nothing Or _
        Not Intersect(cCell, Columns("S")) Is Nothing) _
        And LCase(cCell.Value) = "x" Then
        cCell = Format(Now, "mm/dd/yyyy")
    End If
Next cCell

Open in new window



8) You should end up with this:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cCell As Range

For Each cCell In Target
    If (Not Intersect(cCell, Columns("N")) Is Nothing Or _
        Not Intersect(cCell, Columns("P")) Is Nothing Or _
        Not Intersect(cCell, Columns("Q")) Is Nothing Or _
        Not Intersect(cCell, Columns("R")) Is Nothing Or _
        Not Intersect(cCell, Columns("S")) Is Nothing) _
        And LCase(cCell.Value) = "x" Then
        cCell = Format(Now, "mm/dd/yyyy")
    End If
Next cCell


End Sub

Open in new window


9) SAVE and Exit the workbook.
10) open it and give it a try in all cases.

NOTE:
One thing I added is that you can import more than 1 email at a time. To do that select few emails in 1 folder that follows (just to try) and then goto Excel and press Save Links and see what happens. Choose some that have attachments some that don't and some horizontal and some vertical ...

Let me know.
gowflow
0
 

Author Comment

by:JaseSt
Comment Utility
thanks gowflow. tried it on one email with attachments and it worked perfectly - a vertical format. waiting to try it on multiple.

I'll be adding more functionality to this.

Will give you feedback shortly regarding multiple emails. Good idea.

Thanks again.
0
 

Author Comment

by:JaseSt
Comment Utility
Problems.

Had 4 emails come in that I selected and clicked Save Links. Three had attachments one had none. It looks like the code reads from the oldest date of the incoming emails and inputs that first.

First email: vertical, 4 attachments, imported everything correctly: name, attachments, email address, date and not assigned yet.

2nd email: had two attachments - correctly extracted the name, date and not assigned yet, however two attachments from the 3rd email were placed in its row

3rd email: had 4 attachments - placed two of them correctly while the other two were placed in the 2nd email's attachment cells, also the 4th email address was inserted in its place

4th email: had no attachments - no row was created for it and its email address was placed in the 3rd email's spot
0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
Correct.

Please replace the Sub SaveAttachements by the below one.

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, K 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

    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) & ")"
                
                '---> Check to See if Valid Excel File
                FileExt = LCase(Right(strFile, Len(strFile) - InStrRev(LCase(strFile), ".", Len(strFile))))
                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
                        '---> 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")

                        
                        '---> 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"
                    End If
                
                    '---> Close Workbook
                    WB.Close SaveChanges:=False
                    Set WSAttach = Nothing
                    Set WB = Nothing
        
                    Application.DisplayAlerts = False
                    Application.ScreenUpdating = False
        
                
                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



gowflow
0
 

Author Comment

by:JaseSt
Comment Utility
Almost, gowflow. This time had five emails and it did everything perfectly except:

For the first email in the list in put "Last Name" in the first name column. It got the last name column correct. Also, it created two rows because there was five attachments and I need it to fill in the last name and first name for both rows it created.

Also, is it possible that when it inserts the card number it formats the number with no spaces if there are, or takes out dashes if there are? I just need the 16 digits all together and not in scientfic notation.

I think, other than the above, it was perfect. Thank you for your hard work.
0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility

Also, is it possible that when it inserts the card number it formats the number with no spaces if there are, or takes out dashes if there are? I just need the 16 digits all together and not in scientfic notation.


Yes object of a diffrent question as need examples to build a whole sub for that.

For the First and last will look again and revert.
gowflow
0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
Just looked at the First Name Last Name issue and here are my comments:

1) The email you posted had 2 xls files similar (does not help for testing) furthermore the files themselves have the First Name = Last Name so this also does not help for testing which makes me rely on logic of code only as cannot see in the results if data is picking the correct column. So to make yourself and me a favor please post email that contain relevant data so I can test it accordingly.

2) As far as copying more than 4 attachments and First Name / Last Name does not replicate on new rows. Well all this depends where you xls happens to be, if it is amoung the first 4 files picked then it would find the First Name Last Name and they would be updated in the row and when more than 4 attachemnts found then it would copy the entire row to a new row beneith it and you would have this data replicated in all subsequent rows. Now if the first 4 attachements are not an .xls (just .jpg, .pdf or whatever ...) then you would not have this info at the stage of creating a new row and obviously the copied row will not contain any First /Last Name and when the .xls is found it will update the current row with that info leaving you with missing info in some rows. If you need a routine to look at the end of every message and review that all data has been replicated correctly then will need to deal with this separately like I proposed for the no blanks no hypens for Credit Cards. This will have to be a new question and cannot be combined with the CC.

Hope above clarifies.
gowflow
0
 

Author Comment

by:JaseSt
Comment Utility
gowflow, let's skip the problem you addressed above and move on.

In the latest email I just received it had 7 attachments. One attachment was a spreadsheet that had two records with the same last name but different first names. Everything imported correctly except it inserted the first name field as "Last Name" for both rows.

Do you want me to post something here to take a look at?
0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
yes please post this email
gowflow
0
 

Author Comment

by:JaseSt
Comment Utility
ok a copy of it is attached with 5 attachments to it and scrubbed.

New-client-debit-card.msg
0
Why You Should Analyze Threat Actor TTPs

After years of analyzing threat actor behavior, it’s become clear that at any given time there are specific tactics, techniques, and procedures (TTPs) that are particularly prevalent. By analyzing and understanding these TTPs, you can dramatically enhance your security program.

 
LVL 29

Expert Comment

by:gowflow
Comment Utility
the email you atteched has 5 attachments correct and if you look at the Excel file it is not like you discribed it would be !!! although it is an horizontal format file Col P does not have any data and does not have a Card Number Column hence it was treated as a Vertical file reason why it picked B2 as the Last Name and B1 as the First Name whcih obviously in this Case B1 is the header 'Last Name'

I guess you need to advise the diffrent types of Excel that you may encounter so we can streamline and find a common denominator to work on and be able to intercept Horizontal v/a Vertical correctly.

gowflow
0
 

Author Comment

by:JaseSt
Comment Utility
I'm not sure the confusion. I did state in the previous question for horizontal layouts: "However, IF their is no card number in Col P then insert the value "not assigned yet" into Col T."

If I confused, my apologies. There will be plenty of horizontal layouts that have no value in Col P.

The three types of xls files will be:
1. Vertical - which will not have a Col P, obviously
2. Horizontal WITH a card number in Col P (and there could be a number of rows/records with each row having a different first and last name and a different card number)
3. Horizontal WITHOUT a card number in Col P (and there could be a number of rows/records with each row having a different first and last name and no card numbers)

Does this clear it up any?
0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
for 2 and 3 may I take as format the 2 I already have as I recall one already that have CC and the last one does not have CC.

I need to have the exact Field header same as they ocme or there are plenty ?? do you have something standard ??

gowflow
0
 

Author Comment

by:JaseSt
Comment Utility
cc? not sure what you mean.

There often is no column heading in for Column P. Could be blank or could say Card Number. However, it is true that 99% of the time IF there is a card number in Col P it will come in a spreadsheet that has the Col P heading as "Card Number"

The vertical layout will NEVER have a card number.
0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
I did not mean Col P !!!!! I meant header in row 1 for Col A to O !!!
I would appreciate you attach a sample of each of the 2 files you have order avoid further waste of time.
gowflow
0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
Did you get my last post ? I need your 2 files (or 2 type of files horizontal) so I can build a solid template.
Rgds/gowflow
0
 

Author Comment

by:JaseSt
Comment Utility
Here are the three files we use. they do not always come to us in the same file name as the ones attached.

USD-Mastercard-Profile-Sheet.xlsUSD-Mastercard-Profile-Sheet-Res.xlsUntitled-attachment-00039.xls
0
 

Author Comment

by:JaseSt
Comment Utility
would it be better to us a csv file for these instead of xls?
0
 
LVL 29

Accepted Solution

by:
gowflow earned 500 total points
Comment Utility
ok here it is:

1) Make a copy of your latest Applicant Status file and give it a new name.
2) open VBA and delete the Sub SaveAttachments
3) Copy and 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, K 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

    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) & ")"
                
                '---> Check to See if Valid Excel File
                FileExt = LCase(Right(strFile, Len(strFile) - InStrRev(LCase(strFile), ".", Len(strFile))))
                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")

                        
                        '---> 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"
                    End If
                
                    '---> Close Workbook
                    WB.Close SaveChanges:=False
                    Set WSAttach = Nothing
                    Set WB = Nothing
        
                    Application.DisplayAlerts = False
                    Application.ScreenUpdating = False
        
                
                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 test it.

Let me know/gowflow
0
 

Author Comment

by:JaseSt
Comment Utility
I'll try this out, thank you, gowflow, but now need to ask if it would be doable to use a csv file for these instead of xls? They just changed the format of the file I am sent due to a revamp of the website ordering process.
0
 

Author Comment

by:JaseSt
Comment Utility
I would still get the horizontal xls file sent to me, but there would be no more vertical xls files but rather the csv file.
0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
ok pls attach the CSV and I will see it and we will adapt the macro to it. I prefer this to be dealt with a separate related question
gowflow
0
 

Author Comment

by:JaseSt
Comment Utility
I will submit it as a separate question and post it here in a few minutes
0
 

Author Closing Comment

by:JaseSt
Comment Utility
great work yet again, gowflow
0
 

Author Comment

by:JaseSt
Comment Utility
0

Featured Post

6 Surprising Benefits of Threat Intelligence

All sorts of threat intelligence is available on the web. Intelligence you can learn from, and use to anticipate and prepare for future attacks.

Join & Write a Comment

Sparklines have been introduced with Excel 2010 and are a useful tool for creating small in-cell charts, used for example in dashboards. Excel 2010 offers three different types of Sparklines: Line, Column and Win/Loss. What it does not offer is a…
Approximate matching with VLOOKUP and MATCH seems to me to be a greatly under-used technique, and one which is vital for getting good performance out of large lookups. Until recently I would always have advised using an exact match for simplicity an…
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

771 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

7 Experts available now in Live!

Get 1:1 Help Now