如何使用VBA导出数据？

Question

我每天收到6到10封电子邮件，其中包含以下数据，我试图使用VBA从Outlook 2010中提取Excel表格。

护理：

SVL:    66%
ASA:    78
NCF:    10076
NCO:    10403
NCH:    8741
VAR:    3%
AHTF:   644
AHT:    614

保留：

SVL:    82%
ASA:    16
NCF:    1308
NCO:    1240
NCH:    1179
VAR:    -5%
AHTF:   817
AHT:    797

我想在一行中提取关注数据，在第二行提取保留数据。

以下是我正在使用的代码......

Sub Stats()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim olItem As Outlook.MailItem
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim i As Long
Dim rCount As Long
Dim bXStarted As Boolean
Const strPath As String = "Y:\Fido_Stats.xlsx" 'the path of the workbook

If Application.ActiveExplorer.Selection.Count = 0 Then
    MsgBox "No Items selected!", vbCritical, "Error"
    Exit Sub
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
 rCount = xlSheet.UsedRange.Rows.Count
  For Each olItem In Application.ActiveExplorer.Selection
    sText = olItem.Body
    vText = Split(sText, Chr(13))
    'Find the next empty line of the worksheet
     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), "Care:") = 0 Then

      If InStr(1, vText(i), "SVL:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("B2") = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "ASA:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("C2") = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "NCF:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("D2") = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "NCO:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("E2") = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "NCH:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("F2") = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "VAR:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("G2") = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "AHTF:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("H2") = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "AHT:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("I2") = Trim(vItem(1))
        End If
    End If

    If InStr(1, vText(i), "Retention:") = 0 Then

      If InStr(1, vText(i), "SVL:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("B3") = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "ASA:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("C3") = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "NCF:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("D3") = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "NCO:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("E3") = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "NCH:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("F3") = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "VAR:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("G3") = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "AHTF:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("H3") = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "AHT:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("I3") = Trim(vItem(1))
        End If
    End If


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