Question

选项明确

Sub CopyToExcel()
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 = "C:\Users\Rob\Documents\Excel\Excel.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), "Destination -") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("a" & rCount) = Trim(vItem(1))
        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

此代码来自网上，我尝试让它自己工作......

我需要从电子邮件中提取特定数据（超过5000）并在Excel文档中生成它们。我之前从未接触过VBA，只有C＃，Javascript＆amp; C ++。

代码运行，excel表更新为当前日期/时间但没有生成任何内容？

请帮忙吗？

此行我也收到错误“下标超出范围”：

xlSheet.Range("A" & rCount) = Trim(vItem(1))

Answer 1

我认为您需要更改第二个拆分分隔符以匹配第一个分隔符。这将处理下标错误

使用此：

vItem = Split(vText(i), "Destination -")

VBA将某些数据从Outlook导出到Excel运行但什么都没有产生？

1 个答案: