Question

好的，所以我制作了一个宏来复制outlook邮件正文中的元素，如果邮件主题是充分的。唯一的问题是宏会多次添加同一个人。我想知道是否有可能创建一个遍历行的函数，在我开始填充excel工作表之前调用它，然后在它之后执行测试以检查名称是否已经出现在迭代中。我真的不熟悉函数在vba中的工作方式，我非常欣赏一个例子。

Sub ExportToExcel()
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim rCount As Long
    Dim enviro As String
    Dim strPath As String
    Dim ns As NameSpace
    Dim item As Object
    Dim inbox As MAPIFolder
    Dim bodyString As String
    Dim auxString As String
    Dim name As String
    Dim date1 As String
    Dim date2 As String
    ' Get Excel set up
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
 strPath = enviro & "\Documents\test.xlsx"
     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 the message record

    On Error Resume Next
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
'needed for Exchange 2016. Remove if causing blank lines.
If rCount <> 1 Then
rCount = rCount + 1
End If
    Set item = ActiveExplorer.Selection.item(1)
    Set ns = GetNamespace("MAPI")
    Set inbox = ns.GetDefaultFolder(olFolderInbox)
    For Each item In inbox.Items
        If TypeOf item Is MailItem Then
            If item.Subject = "Leave Request" Then
                bodyString = item.Body
                name = item.Sender
                name = Replace(name, ",", "")
                name = Replace(name, "-", " ")
                bodyString = Replace(bodyString, vbCrLf, "")
                bodyString = Replace(bodyString, "Hello, ", "")
                bodyString = Replace(bodyString, " has created a leave request from ", "")
                bodyString = Replace(bodyString, " to ", "")
                bodyString = Replace(bodyString, ". Please find the created Leave Request in attachment Best regards,", "")
                bodyString = Replace(bodyString, " ", "")
                bodyString = Replace(bodyString, " ", "")
                auxString = Right(bodyString, 20)
                date1 = Left(auxString, 10)
                date2 = Right(auxString, 10)
                    xlSheet.Range("A" & rCount) = name
                    xlSheet.Range("B" & rCount) = date1
                    xlSheet.Range("C" & rCount) = date2
                    xlWB.Worksheets("Sheet1").Columns("A:C").EntireColumn.AutoFit
                    rCount = rCount + 1

            End If
        End If
    Next item
     xlWB.Close 1
     If bXStarted Then
         xlApp.Quit
     End If
End Sub

Answer 1

捕获发件人的名称后，将其添加到字典对象中（您将在互联网上找到很多关于如何在VBA中创建和使用字典对象的示例）。然后在开始格式化IF（即bodyString）之前添加If oD.Exists(name) Then条件。如果该名称已存在于字典中，请跳过其余部分。如果该名称不存在，请将其添加到字典中，然后继续格式化bodyString并将其添加到您的工作表中

获取outlook导出中的单个条目以根据名称优化工作表vba宏

1 个答案: