Part 9 to: Import more data into spreadsheet

Posted on 2013-06-17
Medium Priority
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.
Question by:JaseSt
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 3
  • 3
LVL 31

Accepted Solution

gowflow earned 2000 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
            '---> 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
            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
                    objAttachments.Item(I).SaveAsFile strFile
                    If Err <> 0 Then
                        MkDir (Left(strFile, InStrRev(strFile, "\")))
                        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
                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
                    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"))
                            WS.Range("T" & cCell.Row) = "Not Yet Assigned"
                        End If
                        '---> 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
                    '---> 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
                                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
                                    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
                                    '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
                        '---> 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
            '---> 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
MsgBox (lngCount & " Attachments were saved on C drive")

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

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


Author Closing Comment

ID: 39253458

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!
LVL 31

Expert Comment

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.

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.


Author Comment

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.
LVL 31

Expert Comment

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

Author Comment

ID: 39253805

Featured Post

On Demand Webinar: Networking for the Cloud Era

Did you know SD-WANs can improve network connectivity? Check out this webinar to learn how an SD-WAN simplified, one-click tool can help you migrate and manage data in the cloud.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Access developers frequently have requirements to interact with Excel (import from or output to) in their applications.  You might be able to accomplish this with the TransferSpreadsheet and OutputTo methods, but in this series of articles I will di…
This article describes a serious pitfall that can happen when deleting shapes using VBA.
The viewer will learn how to create two correlated normally distributed random variables in Excel, use a normal distribution to simulate the return on different levels of investment in each of the two funds over a period of ten years, and, create a …
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.

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