Question

我正在为一位前老板开发一个编码项目，该老板每年收到数百封电子邮件，信息完全相同。

我编写了一个代码，帮助将这些电子邮件导出到excel。然而，今年电子邮件正在改变。现在它包含了段落形式的一堆信息。

以下是电子邮件的内容：

名称：
  您目前居住在美国吗？   地址：
  城市：
  状态：
  邮编：
  电话：
  电子邮件：
  国籍：
  等级：
  论文字数：
  学校/组织名称：姓名教师姓名：姓名教师电子邮件：电子邮件您的学校/赞助组织是否位于美国？答案学校/组织地址：地址学校/组织城市：城市学校/组织状态：州学校/组织邮政编码：邮政编码学校/组织电话：电话号码学校/组织电子邮件：电子邮件您是如何知道此次比赛的？答案论文：互联网链接

粗体部分是我想要的部分

现在我已经为所有代码工作的代码，除了它似乎无法处理段落部分。

当它导出到Excel文档时，它会在下一部分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

的标题中添加

我对VBA的经验很少，但有一些python和java知识。我知道有一个 RegEx 选项，但我不知道如何在VBA中使用它们。

有没有办法挽救我的段落代码？

以下是完整代码：

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

Answer 1

查看评论/与您的代码比较 -

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

Answer 2

您有一个已知模板，可为电子邮件正文的文本解析提供静态起点和终点。我已经将实际的机制剥离出了所需的价值，并将其转化为“帮助者”。子。

Option Explicit

Public Const testString As String = "Name: Do you currently reside in the United States? " & _
    "Address: City: State: Zip Code: Phone: Email: Citizenship: Grade: Essay Word Count: " & _
    "School / Organization Name: SO Name Teacher Name: T Name Teacher Email: T 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"

Sub main()
    Dim v As Long, vVALs As Variant

    'Somewhere here you get the body of the email
    'I am using the sample string you provided in
    'your question made into a public string above.

    parseEmail testString, vVALs

    'for testing purposes
    'For v = LBound(vVALs) To UBound(vVALs)
    '    Debug.Print vVALs(v)
    'Next v

    With Worksheets("Sheet1")
        With .Cells(Rows.Count, "N").End(xlUp)
            .Resize(1, UBound(vVALs) + 1).Offset(1, 0) = vVALs
            Erase vVALs
        End With
    End With
End Sub

Sub parseEmail(ByVal str As String, ByRef pcs As Variant)
    Dim tmp As String, v As Long, vSRTs As Variant, vSTPs As Variant

    vSRTs = Array("School / Organization Name: ", "Teacher Name: ", "Teacher Email: ", _
                  "organization based in the United States? ", "School / Organization Address: ", _
                  "School / Organization City: ", "School / Organization State: ", _
                  "School / Organization Zip Code: ", "School / Organization Phone: ", _
                  "School / Organization Email: ", "find out about this contest? ", _
                  "Essay Document: ")
    vSTPs = Array(" Teacher", " Teacher", " Is your school", " School / Or", " School / Or", _
                  " School / Or", " School / Or", " School / Or", " School / Or", _
                  " How did you find", " Essay ")

    For v = LBound(vSRTs) To UBound(vSRTs) - 1
        str = Mid$(str, InStr(1, str, vSRTs(v), vbTextCompare) + Len(vSRTs(v)))
        tmp = tmp & Left$(str, InStr(1, str, vSTPs(v), vbTextCompare) - 1) & ChrW(8203)
    Next v
    str = Mid$(str, InStr(1, str, vSRTs(v), vbTextCompare) + Len(vSRTs(v)))
    tmp = tmp & str

    pcs = Split(tmp, ChrW(8203))

End Sub

当然，这确实取决于维护传入电子邮件正文的模板格式，但通常这些格式相当规律。这里的实际代码非常少;大多数文本和空间由测试字符串以及起始和终止标头值的存储/分配占用。

如何拆分段并导出到Excel

2 个答案: