Part 5 to: Import more data into spreadsheet
This is a continuation of https://www.experts-exchange.com/questions/28143009/Part-4-to-Import-more-data-into-spreadsheet.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.
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.
ASKER
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
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
Pls confirm before I post the solution.
gowflow
ASKER
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.
It will NOT happen with a csv file. Their will always be only one record in a csv file.
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
4) SAVE and Exit the workbook
5) Open it and try it with all kind of attachments.
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 Sub4) SAVE and Exit the workbook
5) Open it and try it with all kind of attachments.
ASKER
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.)
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.)
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
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
ASKER
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?
Maybe your function should not look for the 8th value but for the @ sign?
can you please check several emails and revert with how many are correct how many not ?
gowflow
gowflow
ASKER
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.
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.
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
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
ASKER
I would think so and if they ever change that, I'll ask them to change it back so that they are.
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
4) SAVE and Exit
5) Try it out with all kind of files.
gowflow
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 Sub4) SAVE and Exit
5) Try it out with all kind of files.
gowflow
ASKER
tried it out. same result as before. Came back as Malta
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
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
ASKER
can't you just look for the @ sign to identify the email address?
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Yes, that worked for various emails I tried. Thanks again, gowflow. You're a master!
:( ... am a Sage !!! :)
ASKER
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?
And, we've got more cool things to do with this spreadsheet. Ready?
ASKER
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
pls post it and will look at it. It usually pick O2 as O1 has Email Address in there
gowflow
gowflow
ASKER
attached is screenshot of offending file and email
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
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
ASKER
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
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
ASKER
ASKER
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.
One thing I do not understand is the following.
You said the file attached USD-Mastercard-Profile-She
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
You said the file attached USD-Mastercard-Profile-She
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
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
4) SAVE and Exit the workbook.
5) open it and give it a try
gowflow
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 Sub4) SAVE and Exit the workbook.
5) open it and give it a try
gowflow
ASKER
fantastic! works perfectly.
Thanks again, gowlfow
Thanks again, gowlfow
Are you sure ??? did u try it inside out ??
gowflow
gowflow
ASKER
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.
ok fine, lets cross fingers !!!
Any other issue pls do not hesitate to post it here.
gowflow
Any other issue pls do not hesitate to post it here.
gowflow
ASKER
Here's the next one, gowflow:
https://www.experts-exchange.com/questions/28156423/Part-6-to-Import-more-data-into-spreadsheet.html
https://www.experts-exchange.com/questions/28156423/Part-6-to-Import-more-data-into-spreadsheet.html
gowflow