I am working on a coding project for a former boss who receives hundreds of Emails with exactly the same information every year.
I wrote a code that helped export those emails to excel. However, this year the email body changed. Now it includes a bunch of information in paragraph form.
Here is what the email looks like:
Name:
Do you currently reside in the United States?
Address:
City:
State:
Zip Code:
Phone:
Email:
Citizenship:
Grade:
Essay Word Count:
School / Organization Name: Name Teacher Name: Name Teacher Email: Email Is your school / sponsoring organization based in the United States? Answer School / Organization Address: Address School / Organization City: City School / Organization State: State School / Organization Zip Code: Zip Code School / Organization Phone: Phone Number School / Organization Email: Email How did you find out about this contest? Answer Essay Document: internet link
The bold parts are the parts I want
Right now the code I have works for everything, except it cannot seem to handle the paragraph part.
When it exports to Excel document, it adds in the header for the next section Here is a picture of the spreadsheet. The bold text is being imported correctly, the non-bold text next to it should not be there
I have very little experience with VBA, but some python and java knowledge. I know there is a RegEx option, but I have no idea how to use them in VBA.
Is there any way to salvage the paragraph code I have?
Here is the full code:
Option Explicit
Sub CopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim olItem As MailItem
Dim vText As Variant
Dim vPara As Variant
Dim sText As String
Dim vItem As Variant
Dim i As Long
Dim aa As Long
Dim rCount As Long
Dim sLink As String
Dim bXStarted As Boolean
Const strPath As String = "C:\Users\labuser\Desktop\studentinfo.xlsx" 'the path of the workbook'
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
End If
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Sheet1")
'Process each selected record
For Each olItem In Application.ActiveExplorer.Selection
sText = olItem.Body
vText = Split(sText, Chr(13))
vPara = Split(sText, Chr(13))
'Find the next empty line of the worksheet
rCount = xlSheet.UsedRange.Rows.Count
rCount = rCount + 1
'Check each line of text in the message body
For i = UBound(vText) To 0 Step -1
If InStr(1, vText(i), "Name:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("A" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Do you current reside in the United States?") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("B" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Address:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("C" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Address 2:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("D" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "City:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("E" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "State:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("F" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Zip Code:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("G" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Country:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("H" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Phone:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("I" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Email:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("J" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Citizenship:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("K" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Grade:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("L" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Essay Word Count:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("M" & rCount) = Trim(vItem(1))
End If
Next i
For aa = UBound(vPara) To 0 Step -1
If InStr(1, vPara(aa), "School / Organization Name: ") > 0 Then
vText = Split(vPara(aa), Chr(58))
xlSheet.Range("N" & rCount) = Trim(Replace(vItem(1), "School / Organization Name: ", ""))
xlSheet.Range("O" & rCount) = Trim(Replace(vText(2), "Teacher Name: ", ""))
xlSheet.Range("P" & rCount) = Trim(Replace(vText(3), "Teacher Email: ", ""))
xlSheet.Range("Q" & rCount) = Trim(Replace(vText(4), " Is your school / sponsoring organization based in the United States?", ""))
xlSheet.Range("R" & rCount) = Trim(Replace(vText(5), " School / Organization Address: ", ""))
xlSheet.Range("S" & rCount) = Trim(Replace(vText(6), " School / Organization City: ", ""))
xlSheet.Range("T" & rCount) = Trim(Replace(vText(7), " School / Organization State: ", ""))
xlSheet.Range("U" & rCount) = Trim(Replace(vText(8), " School / Organization Zip Code: ", ""))
xlSheet.Range("V" & rCount) = Trim(Replace(vText(9), " School / Organization Phone: ", ""))
xlSheet.Range("W" & rCount) = Trim(Replace(vText(10), " School / Organization Email: ", ""))
End If
Next aa
xlWB.Save
Next olItem
xlWB.Close SaveChanges:=True
If bXStarted Then
xlApp.Quit
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing
End Sub
See comments on / Compare it with your Code -
Option Explicit
Sub CopyToExcel()
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim olItem As Outlook.MailItem
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim i As Long
Dim RowCount As Long
Dim sLink As String
Dim bXStarted As Boolean
Dim FilePath As String
Dim sReplace As String
FilePath = "C:\Temp\Book1.xlsx" 'the path of the xl workbook'
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
End If
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'// Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(FilePath) ' Open xlFile
Set xlSheet = xlWB.Sheets("Sheet1") ' use Sheet1 or Sheet name
'// Process each selected Mail Item
For Each olItem In Application.ActiveExplorer.Selection
sText = olItem.body ' Email Body
vText = Split(sText, Chr(13)) ' Chr(13) = Carriage return
' vPara = Split(sText, Chr(13))
'// Find the next empty line of the worksheet
RowCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(xlUp).Row
RowCount = RowCount + 1
'// Check each line of text in the message body down loop
For i = UBound(vText) To 0 Step -1
'// InStr([start,]mainString, SearchedString[, compare])
If InStr(1, vText(i), "Name:") > 0 Then
'// Split vItem : & :
vItem = Split(vText(i), Chr(58)) ' Chr(58) = :
'// Trim = String whose both side spaces needs to be trimmed
xlSheet.Range("A" & RowCount) = Trim(vItem(1)) ' (1) = Position
End If
'// Do you current reside in the United States?
If InStr(1, vText(i), "Do you current reside in the United States?") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("B" & RowCount) = Trim(vItem(1))
End If
'// Address:
If InStr(1, vText(i), "Address:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("C" & RowCount) = Trim(vItem(1))
End If
'// Address 2:
If InStr(1, vText(i), "Address 2:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("D" & RowCount) = Trim(vItem(1))
End If
'// City:
If InStr(1, vText(i), "City:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("E" & RowCount) = Trim(vItem(1))
End If
'// State:
If InStr(1, vText(i), "State:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("F" & RowCount) = Trim(vItem(1))
End If
'// Zip Code:
If InStr(1, vText(i), "Zip Code:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("G" & RowCount) = Trim(vItem(1))
End If
'// Country:
If InStr(1, vText(i), "Country:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("H" & RowCount) = Trim(vItem(1))
End If
'// Phone:
If InStr(1, vText(i), "Phone:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("I" & RowCount) = Trim(vItem(1))
End If
'// Email:
If InStr(1, vText(i), "Email:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("J" & RowCount) = Trim(vItem(1))
End If
'// Citizenship:
If InStr(1, vText(i), "Citizenship:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("K" & RowCount) = Trim(vItem(1))
End If
'// Grade:
If InStr(1, vText(i), "Grade:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("L" & RowCount) = Trim(vItem(1))
End If
'// Essay Word Count:
If InStr(1, vText(i), "Essay Word Count:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("M" & RowCount) = Trim(vItem(1))
End If
'// School / Organization Name
If InStr(1, vText(i), "School / Organization Name:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("N" & RowCount) = Trim(Replace(vItem(1), "Teacher Name", ""))
End If
'// Teacher Name
If InStr(1, vText(i), "Teacher Name:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("O" & RowCount) = Trim(Replace(vItem(2), "Teacher Email", ""))
End If
'// Teacher Email
If InStr(1, vText(i), "Teacher Email:") > 0 Then
vItem = Split(vText(i), Chr(32))
xlSheet.Range("P" & RowCount) = Trim(vItem(10))
End If
'// Is your school / sponsoring organization based in the United States?
If InStr(1, vText(i), "Is your school / sponsoring organization based in the United States?") > 0 Then
vItem = Split(vText(i), Chr(32)) 'Chr(32) = space
xlSheet.Range("Q" & RowCount) = Trim(vItem(22))
End If
'// School / Organization Address:
If InStr(1, vText(i), "School / Organization Address:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("R" & RowCount) = Trim(Replace(vItem(4), "School / Organization City", ""))
End If
'// School / Organization City:
If InStr(1, vText(i), "School / Organization City:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("S" & RowCount) = Trim(Replace(vItem(5), "School / Organization State", ""))
End If
'// School / Organization State:
If InStr(1, vText(i), "School / Organization State:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("T" & RowCount) = Trim(Replace(vItem(6), "School / Organization Zip Code", ""))
End If
'// School / Organization Zip Code:
If InStr(1, vText(i), "School / Organization Zip Code:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("U" & RowCount) = Trim(Replace(vItem(7), "School / Organization Phone", ""))
End If
'// School / Organization Phone:
If InStr(1, vText(i), "School / Organization Phone:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("V" & RowCount) = Trim(Replace(vItem(8), "School / Organization Email", ""))
End If
'// School / Organization Email:
If InStr(1, vText(i), "School / Organization Email") > 0 Then
vItem = Split(vText(i), Chr(32))
xlSheet.Range("W" & RowCount) = Trim(vItem(56))
End If
'// How did you find out about this contest?
If InStr(1, vText(i), "How did you find out about this contest?") > 0 Then
vItem = Split(vText(i), Chr(32))
xlSheet.Range("X" & RowCount) = Trim(vItem(65))
End If
'// Essay Document:
If InStr(1, vText(i), "Essay Document:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("Y" & RowCount) = Trim(vItem(10))
End If
Next i
xlWB.Save
Next olItem
'// Save & close workbook
xlWB.Close SaveChanges:=True
If bXStarted Then
xlApp.Quit
End If
'// Cleanup
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing
End Sub