Solved

Part 9 to: Import more data into spreadsheet

Posted on 2013-06-17
6
237 Views
Last Modified: 2013-06-17
Continuing on from: http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28157691.html

Now needing the card number imported from Col T Applicant Status.xls to Col D in the Blank.xls file (and saved as First Name Last Name - New Card Load.xls) to be formatted so that there is no spaces or dashes (or anything separating the number) but just one long 16 digit number and NOT in scientific notation.

Also, need that number in Col T of Applicant Status.xls - when extracted from a emailed spreadsheet (see http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28113301.html) - to be forced to format into one long 16 digit number as well.

They often email the number separated by dashes or spaces.

Thank you.
0
Comment
Question by:JaseSt
  • 3
  • 3
6 Comments
 
LVL 29

Accepted Solution

by:
gowflow earned 500 total points
ID: 39253203
ok here it is:

1) Make a copy of your latest file and give it a new name
2) Goto VBA and doublclick on Sheet1 and delete Sub SaveAttachments and copy paste 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
Dim lOrder As Long
Dim sOrder 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
                
                '---> Insert Order Number
                If InStr(1, LCase(objMsg.Subject), "order") <> 0 Then
                    lOrder = InStr(1, LCase(objMsg.Subject), "order") + 6
                    sOrder = Mid(objMsg.Subject, lOrder, InStr(lOrder, LCase(objMsg.Subject), " ") - lOrder)
                    WS.Range("I" & cCell.Row) = "WO " & sOrder
                Else
                    WS.Range("I" & cCell.Row) = objMsg.SenderEmailAddress
                End If
                
                '---> Insert Hyperlink
                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, 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 = "@"
                            WS.Range("T" & cCell.Row) = ProcessCC(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


3) SAVE the workbook
4) Doubleclick on Module1 and copy paste the below function after any End Sub in Module1

Function ProcessCC(CC As String) As String
   
Dim ILength As Integer, I As Integer
Dim CCFormat As String
   

ILength = Len(CC)
For I = 1 To ILength
    If IsNumeric(Mid(CC, I, 1)) And Mid(CC, I, 1) <> " " Then
        CCFormat = CCFormat & Mid(CC, I, 1)
    End If
Next I

ProcessCC = CCFormat

End Function

Open in new window


5) SAVE and exit the workbook.
6) open it and give it a try

gowflow
0
 

Author Closing Comment

by:JaseSt
ID: 39253458
Perfect!

Ready for the next one? Trying to get this whole thing automated as you can tell. It's repeated actions for me that you are helping me with a LOT!
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39253682
ok fine no problem pls go ahead. Appreciate you do not mention my nick in your questions order not offend other Experts. Tks ur understanding.
gowflow
0
Better Security Awareness With Threat Intelligence

See how one of the leading financial services organizations uses Recorded Future as part of a holistic threat intelligence program to promote security awareness and proactively and efficiently identify threats.

 

Author Comment

by:JaseSt
ID: 39253697
will do. Having a slight problem now that I just noticed. When I put or delete a value from Col Q, O, R or any column, it is now asking me if I want to send an email.
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39253779
oops !!! My mistake, here is the fix

1) Open your latest file
2) goto vba and doubleclick on sheet1 and display worksheet_change event
3) Delete all the code that is between Sub Worksheet_Change and the last line End Sub
4) Paste the below code after Sub Worksheet_change

Dim cCell As Range
Dim fName As String

For Each cCell In Target
    If (Not Intersect(cCell, Columns("O")) 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

'---> Send Email if Cell in Col N has a value and Cell in Col K
If Not Intersect(Target, Columns("N")) Is Nothing Or Not Intersect(Target, Columns("K")) Is Nothing Then
    If Range("N" & Target.Row) <> "" And _
        Range("K" & Target.Row) <> "" Then
        If MsgBox("Send Mail for " & Cells(Target.Row, "C") & ", " & Cells(Target.Row, "B") & " ?", vbQuestion + vbYesNo, "Send Email") = vbYes Then
            fName = CreateNewCardLoad(Range(Cells(Target.Row, "A"), Cells(Target.Row, "T")))
            SendEmail Range(Cells(Target.Row, "A"), Cells(Target.Row, "T")), fName
        End If
    End If
End If

Open in new window


5) SAVE and Exit
6) Try it

Sorry for that
gowflow
0
 

Author Comment

by:JaseSt
ID: 39253805
0

Featured Post

Enabling OSINT in Activity Based Intelligence

Activity based intelligence (ABI) requires access to all available sources of data. Recorded Future allows analysts to observe structured data on the open, deep, and dark web.

Join & Write a Comment

Suggested Solutions

A2 = A1 That kind of cell reference is relative.  If you copy it from A2 to B2, then B2 will get this: B2 = B1 That's all fine and good, but if you then insert a new row above row 2, you'll find: A3 = A1 B3 = B1 This is intentional. …
This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
The viewer will learn how to use a discrete random variable to simulate the return on an investment over a period of years, create a Monte Carlo simulation using the discrete random variable, and create a graph to represent the possible returns over…
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.

705 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

14 Experts available now in Live!

Get 1:1 Help Now