How to use delimiters in VBA message body - outlook to excel - excel

I'm trying to make my life easier by transferring data from automated email forms to Excel.
Emails are formatted like..
Select Place:STACK
First Name:John
Last Name:Doe
Phone number:07555555555
Email:john.doe#example.com
Query String:
I understand I have to choose the column headings and then use a delimiter to separate the variable strings but I can't find clear examples in the searches to do this.
I tried adjusting a similar code but this doesn't separate the information properly...
Sub Extract()
On Error Resume Next
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("mapi")
Set myfolder = myOlApp.ActiveExplorer.CurrentFolder
Set xlobj = CreateObject("excel.application")
xlobj.Visible = True
xlobj.Workbooks.Add
xlobj.Range("a" & 1).Value = "Place"
xlobj.Range("b" & 1).Value = "First"
xlobj.Range("c" & 1).Value = "Last"
xlobj.Range("d" & 1).Value = "Phone"
xlobj.Range("e" & 1).Value = "Email"
For I = 1 To myfolder.Items.Count
Set myitem = myfolder.Items(I)
msgtext = myitem.Body
delimtedMessage = Replace(delimitedMessage, "Select place:", "$")
messageArray(0) = Split(delimitedMessage, "$")
delimtedMessage = Replace(delimitedMessage, "First name:", "$")
messageArray(1) = Split(delimitedMessage, "$")
delimtedMessage = Replace(delimitedMessage, "Last name:", "$")
messageArray(2) = Split(delimitedMessage, "$")
delimitedMessage = Replace(delimitedMessage, "Phone number:", "#")
messageArray(3) = Split(delimitedMessage, "#")
delimitedMessage = Replace(delimitedMessage, "Email:", "$")
messageArray(4) = Split(delimtedMessage, "$")
xlobj.Range("a" & I + 1).Value = messageArray(0)
xlobj.Range("b" & I + 1).Value = messageArray(1)
xlobj.Range("c" & I + 1).Value = messageArray(2)
xlobj.Range("d" & I + 1).Value = messageArray(3)
xlobj.Range("e" & I + 1).Value = messageArray(4)
Next
End Sub
Should be formatted like this...
Place First Last Phone Email
STACK John Doe 07555555555 john.doe#example.com
Anyone that could help adjust it or point me somewhere useful for how to use delimiters in this format that would be great :D

Related

Display error message and resume loop

I have created a VBA Macro code to generate emails with different recipients, subjects, mail content, attachments etc using various criterion...
The code works fine, EXCEPT when there is an issue with the attachments. When the macro fails to find a relevant file at the given location, it gives a popup message BUT DOES NOT progress the loop further.
My questions is, if anyone could please see where should the "Next" and "Exit Sub" be placed so as to keep on looping and generating "Error Popups" together with the "Email drafts" without stopping the code.
Thanks in advance...
Please find the code below...
Sub Email_Creation_Tool()
On Error GoTo ErrMsg
Dim wbk As Workbook
Dim OutApp As Object
Dim OutMail As Object, signature As String
Dim i As Range, j As Long
Dim objItem As Object
With ActiveSheet
Set i = Range("A2", Range("A2").End(xlDown))
For j = 1 To i.Rows.Count
Set OutApp = CreateObject("Outlook.Application")
If Cells(j + 1, 1).Value <> "" Then
Mailto = Cells(j + 1, 3).Value
If Mailto = "Sentence No. 1" Then
Mailto = "Friend1#abc.com"
MailSubject = Cells(j + 1, 1).Value & " Sentence No. 1"
MailBody = " Hi blah blah "
End If
If Mailto = "Sentence No. 2” Then
Mailto = "Friend2#abc.com; Friend3#abc.com"
CCTo = "CommonFriend#abc.com"
MailSubject = Cells(j + 1, 1).Value & " Sentence No. 2"
MailBody = "Hi blah blah,"
End If
If Mailto = "Sentence No. 2” Then
MailSubject = Cells(j + 1, 1).Value & " Sentence No. 3"
Mailto = "Friend2#abc.com; Friend3#abc.com"
CCTo = "CommonFriend#abc.com"
MailBody = " Hi blah blah "
End If
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(o)
With OutMail
.Display
signature = OutMail.body
With OutMail
.Subject = MailSubject
.To = Mailto
.CC = CCTo
.body = MailBody & vbNewLine & signature
Name "D:\Users\MY_PC\Desktop\" & Cells(j + 1, 1).Value & ".txt" As "D:\Users\MY_PC\Desktop\" & Cells(j + 1, 1).Value & "_trial.txt"
Attach = "D:\Users\MY_PC\Desktop\" & Cells(j + 1, 1).Value & "_trial.txt"
.Attachments.Add (Attach)
Exit Sub 'where should this be placed
On Error Resume Next 'where should this be placed
End With
Set OutMail = Nothing
Set OutApp = Nothing
End With
End If
On Error Resume Next 'where should this be placed
ErrMsg:
MsgBox ("Attachment WP" & (Cells(j + 1, 1).Value) & vbNewLine & _
"Not Found/Name Incorrect")
Next j
End With
End Sub
I edited your code "slightly", give it a try :
EDIT
What I changed is, I used "Select case" instead of multiple "Ifs", as you have multiple If's options. Then I added ".Save" and ".Close olpromptforsave" to save and close message window, in case it has attachment or no. Goto is good for jumping through code, like in this case.
So logic is:
if you don't find file to attach, skip to error message, then continues with nextJ code: save and close, proceed to another "j" (nextJ code runs no matter if file is found or not)
If you find file to attach, attach it, save, close, skip error message and continue to another "j"
Sub Email_Creation_Tool()
Dim wbk As Workbook
Dim OutApp As Object, OutMail As Object, objItem As Object
Dim i As Integer, j As Long, signature As String
For j = 2 To Range("A" & Rows.Count).End(xlUp).Row
If Cells(j + 1, 1).Value <> vbNullString Then
Mailto = Cells(j + 1, 3).Value
select case Mailto
case "Sentence No. 1"
Mailto = "Friend1#abc.com"
MailSubject = Cells(j + 1, 1).Value & " Sentence No. 1"
MailBody = " Hi blah blah "
case "Sentence No. 2"
Mailto = "Friend2#abc.com; Friend3#abc.com"
CCTo = "CommonFriend#abc.com"
MailSubject = Cells(j + 1, 1).Value & " Sentence No. 2"
MailBody = "Hi blah blah,"
case "Sentence No. 3"
MailSubject = Cells(j + 1, 1).Value & " Sentence No. 3"
Mailto = "Friend2#abc.com; Friend3#abc.com"
CCTo = "CommonFriend#abc.com"
MailBody = " Hi blah blah "
End Select
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Display
signature = OutMail.body
.Subject = MailSubject
.To = Mailto
.CC = CCTo
.body = MailBody & vbNewLine & signature
Attach = "D:\Users\MY_PC\Desktop\" & Cells(j + 1, 1).Value & "_trial.txt"
If Dir(Attach) = vbNullString then GoTo ErrMsg
.Attachments.Add (Attach)
GoTo nextJ
ErrMsg:
MsgBox ("Attachment WP " & (Cells(j + 1, 1).Value) & vbNewLine & "Not Found/Name Incorrect")
nextJ:
.Save
.Close olpromptforsave
End With
End If
Next j
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Try using Go to statement Please look into this link

Email option embeded in Submit button Excel VBA

I have this Submit button and I want to send an email notification to a person regarding on the status of the Quality checking. I want to happen is if the Quality Checker ticked a Checkbox the Caption for all selected checkbox will be included in. Body of EMail but I cant figure it out on how to code. here is my Submit button code.
Private Sub CommandButton4_Click()
If VERIFY_ENTRY = False Then Exit Sub
Dim RowCounter As Long
Dim rowCount As Long
Dim ctrl As Control
Dim Score As Double
Dim num As String
Dim OutMail As Object
Dim strbody1 As String
Dim OutApp As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
RowCounter = 0
Score = 1
For Each ctrl In Me.Controls
Select Case TypeName(ctrl)
Case Is = "CheckBox"
If Me.Controls(ctrl.Name).Value = True Then Score = Score - GETSCORE(Me.Controls(ctrl.Name).Name)
End Select
Next ctrl
Me.TextBox6.Value = Format(Score, "Percent")
If MsgBox("Submit RFP results?", vbQuestion + vbYesNo, "") = vbNo Then GoTo endmacro
'Data Sheet Transfer
rowCount = Worksheets("Quality Database").Range("A1").CurrentRegion.Rows.Count
With Worksheets("Quality Database").Range("A" & rowCount + 1)
.Offset(RowCounter, 0).Value = Now()
.Offset(RowCounter, 1).Value = Me.TextBox2.Value
.Offset(RowCounter, 2).Value = Me.ComboBox1.Value
.Offset(RowCounter, 3).Value = Me.ComboBox2.Value
.Offset(RowCounter, 4).Value = Me.ComboBox3.Value
.Offset(RowCounter, 6).Value = "Initial prep/load"
.Offset(RowCounter, 9).Value = Me.ComboBox4.Value
.Offset(RowCounter, 10).Value = Round(Score * 100, 2)
.Offset(RowCounter, 11).Value = Format(Me.TextBox3.Value, "hh:mm:ss") 'Start Time
.Offset(RowCounter, 12).Value = Format(Me.TextBox4.Value, "hh:mm:ss") 'End Time
.Offset(RowCounter, 13).Value = Format(Me.TextBox5.Value, "hh:mm:ss") 'Time Spent
.Offset(RowCounter, 13).NumberFormat = "hh:mm:ss"
' Attributes Target
For Each ctrl In Me.Controls
Select Case TypeName(ctrl)
Case Is = "CheckBox"
If Me.Controls(ctrl.Name).Value = True Then
'if not other checkbox
If Me.Controls(ctrl.Name).Caption <> "Other" Then
.Offset(RowCounter, 7).Value = vbCrLf & Me.Controls(ctrl.Name).Caption
RowCounter = RowCounter + 1
Else
'get number from checkbox name
num = Mid(ctrl.Name, 9)
.Offset(RowCounter, 7).Value = vbCrLf & Me.Controls(ctrl.Name).Caption
.Offset(RowCounter, 8).Value = Me.Controls("Textbox" & num).Value
RowCounter = RowCounter + 1
End If
End If
End Select
Next ctrl
If RowCounter = 0 Then .Offset(RowCounter, 7).Value = "Everything was Completed Satisfactory!"
If Me.ComboBox4.Value = "Pending - Team Meeting" Then
.Offset(RowCounter, 7).Value = ""
.Offset(RowCounter, 10).Value = ""
End If
If Me.ComboBox4.Value = "Pending - 1st Break" Then
.Offset(RowCounter, 7).Value = ""
.Offset(RowCounter, 10).Value = ""
End If
If Me.ComboBox4.Value = "Pending - Lunch Break" Then
.Offset(RowCounter, 7).Value = ""
.Offset(RowCounter, 10).Value = ""
End If
If Me.ComboBox4.Value = "Pending - 2nd Break" Then
.Offset(RowCounter, 7).Value = ""
.Offset(RowCounter, 10).Value = ""
End If
If Me.ComboBox4.Value = "Pending - Coaching" Then
.Offset(RowCounter, 7).Value = ""
.Offset(RowCounter, 10).Value = ""
End If
End With
'MessageBox
MsgBox "Data added", vbOKOnly + vbInformation, ""
endmacro:
'Clear Data
If Me.ComboBox4.Value = "Completed" Then ' Enable Email Notification
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
With OutMail
.Display
If Me.ComboBox1.Value = "Name1" Then
.To = "name#email`enter code here`.com"
End If
If Me.ComboBox1.Value = "Name2" Then
.To = "name#email.com"
End If
If Me.ComboBox1.Value = "Name3 " Then
.To = "name#email.com"
End If
.CC = ""
.BCC = ""
.Subject = TextBox2.Value & " - Review Completed & " & Now()
.Body = "Hi," & vbCrLf & vbCrLf & "Please see comment below"
.Display 'change to .send if you want the email sent automatically
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
INIT_FORM
Me.TextBox2.SetFocus
'Save worksheet
ThisWorkbook.Save
End If
End Sub
This function will extract the caption from every selected checkbox on your form.
The function uses a For Each...Next loop to check each control. I've used vbCrLf to delimit the checkboxes with new lines, which should make the final text easier to read.
' Builds and returns the email body.
Private Function GetMailBody() As String
Dim i As Integer ' Counts number of selected checkboxes.
Dim mailBody As String ' Build the email message body here.
Dim cntl As Control ' Used to loop over controls, looking for checkboxes.
' Add body.
For Each cntl In Me.Controls
' We only want checkboxes.
If TypeName(cntl) = "CheckBox" Then
' Append selected boxes caption to mailBody.
If cntl.Value = True Then
i = i + 1
mailBody = mailBody & vbCrLf & cntl.Caption
End If
End If
Next
' Update body, based on count of selected items.
If i > 1 Then
mailBody = "Opening text" & vbCrLf & mailBody & vbCrLf & "Closing text"
Else
mailBody = "No items selected."
End If
GetMailBody = mailBody
End Function
To use this function replace the line
.Body = "Hi," & vbCrLf & vbCrLf & "Please see comment below"
with
.Body = GetMailBody()
in your existing code.
EDIT
Updated code to include alternative text, when no items selected.

Find File By knowing the Prefix of File

I am trying to find a file, to send as an attachment to a customer. The user inputs the customer name to get the e-mail address and the file number as a reference to look for the correct file in the Excel sheet. The user also inputs the file path in the Excel sheet.
The issue is that the file name is randomly generated from a different system and I could only identify the first 30 characters from the file name that contains the file number while the rest of the characters is randomly generated.
The VBA code shows "Path not found".
Sub SendEVAT()
Dim strLocation As String
Dim strName As String
Dim fldpath As String
Dim fldpath1 As String
Dim fso As Scripting.FileSystemObject
Dim fsoFile As Scripting.File
Dim fsoFldr As Scripting.Folder
Dim OutApp As Object
Dim OutMail As Object
Dim i As Long
Dim m As Long, n As Long
Dim lastrow As Long
Dim mrow1 As Long, nrow1 As Long
Dim strbody1 As String, strbody2 As String
Dim rng As Range
Dim colm As Integer
colm = Sheets("Input").Range("N4").Value
With Worksheets("Input")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
mrow1 = Sheets("Email Content").Cells(10, 1).End(xlUp).Row
For m = 2 To mrow1
strbody1 = strbody1 & "<br>" & Sheets("Email Content").Cells(m, 1)
Next m
nrow1 = Sheets("Email Content").Cells(15, 2).End(xlUp).Row
For n = 2 To nrow1
strbody2 = strbody2 & "<br>" & Sheets("Email Content").Cells(n, 2)
Next n
For i = 1 To lastrow - 1
Set fso = CreateObject("Scripting.FileSystemObject")
fldpath = Sheets("Input").Range("N2") & "\" & Sheets("Input").Cells(i + 1, 6).Value & "*"
Set fsoFldr = fso.getfolder(fldpath)
If Sheets("Input").Cells(i + 1, 2).Value <> Sheets("Input").Cells(i + 1 - 1, 2) Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set rng = Sheets("Input").Range(Cells(1, 1), Cells(1, colm))
For Each fsoFile In fsoFldr.Files
If fso.GetExtensionName(fsoFile) = "pdf" Then
fldpath1 = fsoFile.Path
End If
Next fsoFile
If Len(fldpath1) = 0 And Sheets("Input").Cells(i + 1, 2).Value <> Sheets("Input").Cells(i + 1 + 1, 2) Then
Sheets("Input").Cells(i + 1, 10).Value = "File Not Found"
With OutMail
.Display
End With
ElseIf Len(Dir(fldpath1)) = 0 And Sheets("Input").Cells(i + 1, 2).Value = Sheets("Input").Cells(i + 1 + 1, 2) Then
Sheets("Input").Cells(i + 1, 10).Value = "File Not Found"
Else
Set rng = Union(rng, Range(Cells(i + 1, 1), Cells(i + 1, colm)))
With OutMail
.To = Sheets("Input").Cells(i + 1, 9).Value
.Subject = Sheets("Input").Range("N3").Value & " " & Sheets("Input").Cells(i + 1, 2).Value
.HTMLBody = "<p style='font-family:verdana;font-size:13'>" & strbody1 & "<p>" & "<br>" & RangetoHTML(rng) & "<br>" & "<p style='font-family:verdana;font-size:13'>" & strbody2 & "<p>"
strLocation = fldpath1
.Attachments.Add (strLocation)
If Sheets("Input").Cells(i + 1, 2).Value <> Sheets("Input").Cells(i + 2, 2) Then
If Sheets("Input").Range("N1").Value = "Send" Then
.Send
Else
.Display
End If
End If
End With
Sheets("Input").Cells(i + 1, 10).Value = "Sent"
Sheets("Input").Cells(i + 1, 7).Value = Date
Sheets("Input").Cells(i + 1, 8).Value = "E-mail"
End If
ElseIf Sheets("Input").Cells(i + 1, 2).Value = Sheets("Input").Cells(i + 1 - 1, 2) Then
For Each fsoFile In fsoFldr.Files
If fso.GetExtensionName(fsoFile) = "pdf" Then
fldpath1 = fsoFile.Path
End If
Next fsoFile
If Len(fldpath1) = 0 And Sheets("Input").Cells(i + 1, 2).Value <> Sheets("Input").Cells(i + 1 + 1, 2) Then
Sheets("Input").Cells(i + 1, 10).Value = "File Not Found"
With OutMail
.Display
End With
ElseIf Len(Dir(fldpath1)) = 0 And Sheets("Input").Cells(i + 1, 2).Value = Sheets("Input").Cells(i + 1 + 1, 2) Then
Sheets("Input").Cells(i + 1, 10).Value = "File Not Found"
Else
Set rng = Union(rng, Range(Cells(i + 1, 1), Cells(i + 1, colm)))
With OutMail
.To = Sheets("Input").Cells(i + 1, 9).Value
.Subject = Sheets("Input").Range("N3").Value & " " & Sheets("Input").Cells(i + 1, 2).Value
.HTMLBody = "<p style='font-family:verdana;font-size:13'>" & strbody1 & "<p>" & "<br>" & RangetoHTML(rng) & "<br>" & "<p style='font-family:verdana;font-size:13'>" & strbody2 & "<p>"
strLocation = fldpath1
.Attachments.Add (strLocation)
If Sheets("Input").Cells(i + 1, 2).Value <> Sheets("Input").Cells(i + 2, 2) Then
If Sheets("Input").Range("N1").Value = "Send" Then
.Send
Else
.Display
End If
End If
End With
Sheets("Input").Cells(i + 1, 10).Value = "Sent"
Sheets("Input").Cells(i + 1, 7).Value = Date
Sheets("Input").Cells(i + 1, 8).Value = "E-mail"
End If
End If
Next i
On Error GoTo 0
'enter code here'End With
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Below is the display of the Excel sheet that will be used by the user
Excel Format
How do I search for the file knowing only the first 30 characters of the file name?

Issues with looping through multiple columns in Excel VBA

My VBA code loops through Column "I" with people's names and creates a list of emails. In email body there's a list of rows for each person from columns B, C, G, I. Pretty straightforward, however I encounter an issue with the latter. It only takes the first row for each person, i.e. doesn't loop through the list to get all of the rows for one recipient.
I have a feeling this somehow stops it from looping further:
If InStr(1, PriorRecipients, EmailAddr) <> 0 Then
GoTo NextRecipient
End If
But not sure how to implement a second loop??
Full code:
Sub SendEmail2()
Dim OutlookApp
Dim MItem
Dim cell As Range
Dim Subj As String
Dim EmailAddr As String
Dim Recipient As String
Dim Msg As String
Dim Projects As String
Dim ProjectsMsg As String
Dim bSendMail As Boolean
'Create Outlook object
Set OutlookApp = CreateObject("Outlook.Application")
Set MItem = OutlookApp.CreateItem(0)
'Loop through the rows
For Each cell In Columns("I").Cells.SpecialCells(xlCellTypeVisible)
If cell.Value <> "" And _
(Cells(cell.Row, "L").Value) = "No" And (Cells(cell.Row, "K").Value) <> "Yes" Then
'first build email address
EmailAddr = LCase$(Replace(cell.Value, " ", ".")) & "#company.com"
'then check if it is in Recipient List build, if not, add it, otherwise ignore
If InStr(1, Recipient, EmailAddr) = 0 Then Recipient = Recipient & ";" & EmailAddr
Projects = vbCrLf & "Document: " & Cells(cell.Row, "B").Value & "; " & Cells(cell.Row, "C").Value & "; " & "Rev " & Cells(cell.Row, "G").Value & "; " & Cells(cell.Row, "I").Value
If InStr(1, ProjectsMsg, Projects) = 0 Then ProjectsMsg = ProjectsMsg & Projects & vbCrLf
If InStr(1, Recipient, cell.Offset(1).Value) <> 0 Then
bSendMail = True
Recipient = Recipient & ";" & cell.Offset(1)
Else
bSendMail = False
End If
End If
Next
Msg = "You have the following outstanding documents to be reviewed at: "& ProjectsMsg
Subj = "Outstanding Documents to be Reviewed"
'Create Mail Item and view before sending
If bSendMail Then Set MItem = OutlookApp.CreateItem(olMailItem)
With MItem
.To = Recipient 'full recipient list
.Subject = Subj
.Body = Msg
.display
End With
End Sub
Change this block of code:
If InStr(1, PriorRecipients, EmailAddr) <> 0 Then
GoTo NextRecipient
End If
PriorRecipients = PriorRecipients & ";" & EmailAddr
To this
If InStr(1, PriorRecipients, EmailAddr) = 0 Then
PriorRecipients = PriorRecipients & ";" & EmailAddr
End If
'checks if it's the last email for that unique person and if so,
`it's done looping rows for that email and the email is good to send
If Instr(1, PriorRecipients, cell.Offset(1).Value) <> 0 Then
Dim bSendMail as Boolean
bSendMail = True
PriorRecipients = PriorRecipients & ";" & cell.Offset(1)
Else
bSendMail = False
End If
If bSendMail Then
Set MItem = OutlookApp.CreateItem(olMailItem)
' rest of code to send mail ...
End If

My Excel macro stops when I open a second workbook

I've searched for something similar to this issue on this board and others and I haven't seen anything that comes close.
I've written a macro that opens a second workbook and then copies info from that workbook to the first and then closes the second workbook.
When I run it in Debug mode, it runs perfectly. When I run it from the 1st workbook (not in the VBE), it stops once the second workbook opens.
The code snippet that I think it is reacting to differently in the two different modes is:
Application.EnableEvents = False
Set newbook = Workbooks.Open(Filename)
Any help, pointers or tips would be greatly appreciated.
Here's the full code:
Sub Pull_Mail()
Dim ol As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olMail As Variant
Dim startrow As Integer
Dim myAttachments As Outlook.Attachment
Dim att As String
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.Folders("Mailbox - informaticsinbox").Folders("Inbox")
startrow = 10 ' This number will need to be adjusted if changes are made to the Tracker
x = Fldr.Items.Count ' Used during debugging
tracker = ThisWorkbook.Name
newcount = 0
For Each olMail In Fldr.Items ' This figures out how many new Intake items are in the mailbox
If Left(olMail.Subject, 35) = "[SEND SECURE] Informatics Request -" Then
newcount = newcount + 1
End If
Next
If newcount > 0 Then
tyear = Right(Year(Now()), 2)
If Len(Month(Now())) < 2 Then
tmonth = "0" & Month(Now())
Else
tmonth = Month(Now())
End If
If Len(Day(Now())) < 2 Then
tday = "0" & Day(Now())
Else
tday = Day(Now())
End If
' This snippet will allow this to be run more than once per day and keep the numbering sequnce in line
If Mid(Cells(startrow, 1).Value, 1, 6) = tyear & tmonth & tday Then
daycount = CInt(Mid(Cells(startrow, 1).Value, 7, 2))
Else
daycount = 0
End If
Add_New_Pull startrow, newcount ' Add new lines
endrow = startrow
For Each olMail In Fldr.Items ' Populate the first three columns based on the mail received
If Left(olMail.Subject, 35) = "My gibberish -" Then
If Len(newcount) < 2 Then
tcount = "0" & (newcount + daycount)
Else
tcount = newcount + daycount
End If
trackerid = tyear & tmonth & tday & tcount
With ActiveSheet
.Cells(endrow, 1) = trackerid
.Cells(endrow, 2) = olMail.ReceivedTime
.Cells(endrow, 3) = Mid(olMail.Subject, 37, Len(olMail.Subject) - 37 - 21)
End With
Create_New_Dirctory_Pull endrow ' Build the directories and hyperlinks for each new item
' The following lines were written to save any attachments to the newly created folder.
' A path name of 260 characters is too long to be able to save via macro. Put a check in and flag a message
' if the path exceeds that.
hlink = Cells(endrow, 3).Hyperlinks(1).Address
hlink = Replace(Trim(hlink), "\\remote.path\", "Z:\")
For Each myAttachments In olMail.Attachments
Filename = Trim(hlink) & "\" & myAttachments.Filename
If Len(Filename) > 259 Then
MsgBox ("The filename for " & trackerid & " is too long, need to move that file manually")
Else
myAttachments.SaveAsFile Filename ', xlExcel8, "", "", False, False
Application.EnableEvents = False
Set newbook = Workbooks.Open(Filename)
Windows(tracker).Activate
PopulateTracker_Pull endrow, tracker, myAttachments.Filename
Application.EnableEvents = True
End If
' MsgBox (Len(Filename))
Next myAttachments
endrow = endrow + 1
newcount = newcount - 1
End If
Next
End If
End Sub
Sub PopulateTracker_Pull(myrow, tracker, myrr)
Windows(myrr).Activate
Sheets("Main Request").Select
whattype = Cells(5, "B").Value
Sheets("Data Validations").Visible = True
Sheets("Data Validations").Select
descloc = Cells(whattype + 1, "G").Value
clientloc = Cells(whattype + 1, "H").Value
reqtype = Cells(whattype + 1, "A").Value
Sheets("Data Validations").Visible = False
Sheets("Main Request").Select
If descloc = 999 Then
desc = "See report request"
Else
desc = Cells(descloc, "B").Value
End If
If clientloc = 999 Then
client = "N/A"
Else
client = Cells(clientloc, "B").Value
End If
requestor = Cells(3, "B").Value
icomplete = Cells(6, "B").Value
Complete = Cells(7, "B").Value
If Len(Complete) < 3 Then
Complete = icomplete
End If
Comment = Cells(8, "B").Value
Windows(tracker).Activate
Sheets("OPEN REQUESTS").Select
Cells(myrow, "D").Value = desc
Cells(myrow, "E").Value = requestor
Cells(myrow, "I").Value = Comment
Cells(myrow, "K").Value = icomplete
Cells(myrow, "L").Value = Complete
'Cells(myrow, "M").Value = complete
Cells(myrow, "R").Value = reqtype
Cells(myrow, "S").Value = client
Cells(myrow, "X").Value = "=if(isblank(M" & myrow & "),L" & myrow & ",M" & myrow & ")"
'ThisWorkbook.Activate
'Sheets("Main Request").Select
Windows(myrr).Activate
ActiveWorkbook.Close False
End Sub

Resources