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\username\Desktop\Spreadsheet.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), "Cell0:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("B" & rCount) = Trim(vItem(1))
            Else
            ActiveCell = Null
        End If

        If InStr(1, vText(i), "Field1:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("D" & rCount) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "Field2:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("E" & rCount) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "Field3:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("F" & rCount) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "Field4:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("H" & rCount) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "Field5:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("I" & rCount) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "Field6:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("J" & rCount) = Trim(vItem(1))
        End If


    Next i
    xlWB.Save
Next olItem


Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing
End Sub

问题是，如果这是在不包含某个字段的数据的电子邮件上运行，则会保留以前的电子邮件数据。如果它包含信息，我想让宏清除单元格，如果在字段中找不到任何内容，则只需在单元格中输入null。

我知道它必须是ActiveCell.clear或ActiveCell = Null，但我不知道将它放在If语句中的哪个位置。

我尝试了这个，但它不起作用：

If InStr(1, vText(i), "Activity Number:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("B" & rCount) = Trim(vItem(1))
            ElseIf InStr(1, vText(i), "Activity Number:") = 0 Then
            xlSheet.Range("B" & rCount) = Null
        End If

Answer 1

你可以写一个函数，在清除它之后返回范围对象。

Function ClearMyRange(r as Range) as Excel.Range
    r.ClearContents
    set ClearMyRange = r
End Function

然后只需称呼它

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

我建议使用该功能的原因是您不必像这样调用它

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

清除单元格如果包含数据

1 个答案: