Part 8 to: Import more data into spreadsheet

Continuing on from:

Now that an email is created when a value is inserted into Col N (with a value in Col K) I need this function to also do the following:

1. Open spreadsheet Blank - New Card Load.xls (example posted - its path is:
C:\Users\Michael\Dropbox\Sovereign\MasterCard\MasterCardLoadRequests/Blank - New Card Load.xls)

2. In Col D of Blank - New Card Load.xls post the value from Col T of Applicant Status

3. In Col H of Blank - New Card Load.xls post the value from Col B from Applicant Status

4. In Col i of Blank - New Card Load.xls post the value from Col C from Applicant Status

5. Save Blank - New Card Load.xls as 'First Name Last Name - New Card Load.xls' to the same location Blank - New Card Load.xls came from
- example save as: Joe Smith - New Card Load.xls

6. And attach it with the other attachments to the email created

(My concern with these functions is what happens when multiple records are in an emailed xls spreadsheet, but guess we'll cross that bridge later.)

If too much for one question, let me know.

Thank you, gowflow!

Who is Participating?
ok here it is:

1) Make a copy of your latest file and give it a new name
2) Goto VBA and doublclick on Module1 and delete all the code that is there.
3) Copy and Paste the below code in Module1

Sub SendEmail(Rng As Range, fName As String)
Dim WB As Workbook
Dim WS As Worksheet

Dim SendTo As String
Dim Blindcc As String
Dim OutlookApp As Object
Dim MItem As Object
Dim subject_ As String
Dim attach_ As String
Dim fFile
Dim omail As Outlook.MailItem

Application.DisplayAlerts = False

'Create Outlook
Set OutlookApp = CreateObject("Outlook.Application")

'Fill in Subject Details'
subject_ = "New Mastercard Application for (" & Rng.Cells(1, "B") & " " & Rng.Cells(1, "C") & ")"
SendTo = ""
Blindcc = ""

'Create the Email
Set MItem = OutlookApp.CreateItem(0)
With MItem
  .To = SendTo
  .BCC = Blindcc
  .Subject = subject_
  '---> Attach files
  For Each fFile In Rng.SpecialCells(xlCellTypeFormulas)
        If InStr(1, fFile.Formula, "HYPERLINK") <> 0 Then
            fpos = InStr(1, fFile.Formula, "HYPERLINK") + 11
            attach_ = Mid(fFile.Formula, fpos, InStr(fpos, fFile.Formula, Chr(34)) - fpos)
            .Attachments.Add (attach_)
        End If
  Next fFile
  .Attachments.Add (fName)
  .Body = "Hi Nalleli," & Chr(10) & Chr(10) _
    & "Attached are the documents and load request for (" & Rng.Cells(1, "B") & " " & Rng.Cells(1, "C") & ")" & Chr(10) _
    & "Please have his card shipped to address indicated on spreadsheet." & Chr(10) _
    & "PIC:99554Freedom" & Chr(10) & Chr(10) _
    & "Please let me know you received this email." & Chr(10) & Chr(10) _
    & "Thank you." & Chr(10) & Chr(10) _
    & "Michael" & Chr(10) _
    & "Sovereign Gold Card Support" & Chr(10) _
    & ""

  'Send the Email
End With

'Clear Resources
Set MItem = Nothing
Set OutlookApp = Nothing

Application.DisplayAlerts = True
End Sub

Function CreateNewCardLoad(Rng As Range) As String
Dim sPathName As String
Dim sFileName As String
Dim sBlankCardLoad As String
Dim MaxRow As Long
Dim WS As Worksheet
Dim WB As Workbook

sBlankCardLoad = "C:\Users\Michael\Dropbox\Sovereign\MasterCard\MasterCardLoadRequests\Blank - New Card Load.xls"
sPathName = "C:\Users\Michael\Dropbox\Sovereign\MasterCard\MasterCardLoadRequests\"

'sBlankCardLoad = ActiveWorkbook.Path & "\Blank - New Card Load.xls"
'sPathName = ActiveWorkbook.Path & "\"

Application.EnableEvents = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Set WB = Workbooks.Open(Filename:=sBlankCardLoad)
Set WS = ActiveSheet
MaxRow = WS.UsedRange.Rows.Count + 1

sFileName = sPathName & Rng.Cells(1, "B") & " " & Rng.Cells(1, "C") & " - New Card Load.xls"

'---> Affect Values to Card Load.xls
WS.Range("D" & MaxRow) = Rng.Cells(1, "T")
WS.Range("H" & MaxRow) = Rng.Cells(1, "B")
WS.Range("I" & MaxRow) = Rng.Cells(1, "C")
WB.SaveAs Filename:=sFileName
CreateNewCardLoad = sFileName
WB.Close savechanges:=True

'---> Clean Variables
Set WB = Nothing
Set WS = Nothing

Application.EnableEvents = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Function

Open in new window

4) SAVE the workbook
5) doubleclick on Sheet1 in the Left pane and select Worksheet Change Event and delete all the code that is between Private Sub Worksheet_Change and End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

>> Delete all the Code that is Here <<

End Sub

6) Copy and Paste the below code after
Private Sub Worksheet_Change(ByVal Target As Range)

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

Open in new window

7) SAVE and Exit the workbook
8) Your blank load file should be named exactly as you mentioned in your post which is:
Blank - New Card Load.xls
and not as the file you posted in here that is

9) the file you posted had data on row 2 and some deleted row until row 35 you need to have this file completely clean like you need to delete all rows from Row 2 to Row 1000 to make sure it is completely clean.

Give it a try and let me know.
JaseStAuthor Commented:
it did everything perfectly except the data was not imported correctly to the renamed Blank - New Card Load sheet. Please see attached.

And I did delete everything from row 2 down for about 50 rows just to make sure. I cleared content and deleted the rows, but still came up with the attached.

saved blank sheet
JaseStAuthor Commented:
as you can see, it put the data into the row below where it should go
Free Tool: Subnet Calculator

The subnet calculator helps you design networks by taking an IP address and network mask and returning information such as network, broadcast address, and host range.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

Well I saw this row and thought it was a sample so I deleted it fine no problem change the following:

In Module1 there is a Sub Called CreateNewCardLoad
change this line
MaxRow = WS.UsedRange.Rows.Count + 1

to be
MaxRow = WS.UsedRange.Rows.Count

JaseStAuthor Commented:
Works perfectly, gowflow, thanks.

I need the card number inserted into the blank xls (the newly created xls file) to be formatted so there is no spaces or dashes. Just one solid 16 digit number NOT in scientific notation. Do you want me to ask another question for that? Because I also need it imported into Applicant Status that way as well.
Yes please as this is a complete different module and to incoroporate it wether in this file or in applicant status is no sweat.
JaseStAuthor Commented:
Gowflow is fantastic!

And I will add the formatting of the card number question here. Thanks once again, gowflow.
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.