0

我需要在 Excel 表的不同列中写入许多 Outlook 电子邮件的数据（如发件人、接收日期、主题...）。我能够在相应的单元格中报告每个电子邮件数据，但性能很慢。我的想法是将电子邮件的数据存储到字典 (dic) 键中，然后将这些数据转置到 Excel 表中。问题是字典键长于 255 并且转置不起作用。我尝试使用数组作为变体并将数组转换为字符串，但我不是真正的专家，我失败了。您能否帮助调整代码，以便我可以在 excel 工作表中转置键（我会将文本添加到列功能以将键值拆分为不同的列）

Sub List_Email_Info()

Dim xlApp As excel.Application
Dim xlWB As excel.Workbook
Dim xlfoldWS, xlWS As excel.Worksheet
Dim wb As Object
Dim Xl As Object
Dim StartTime As Double
Dim SecondsElapsed As Double
Dim dic As Object
Dim OutRecipients As Object
Dim i As Long ' Row tracker
Dim arrHeader As Variant
Dim olNS As NameSpace
Dim olInboxFolder As MAPIFolder
Dim olItems As Object
Dim olMailItem As Object

arrHeader = Array("#", "Date Created", "Subject", "ConversationID", "Sender's Name", "Receiver", "Copy to", "Category", "Country")

On Error Resume Next

On Error Resume Next
Set Xl = GetObject(, "Excel.Application")
If Err <> 0 Then
    MsgBox "Excel is not running"
End If
On Error GoTo 0
Set wb = Xl.Workbooks("MTR.xlsx")
If wb Is Nothing Then
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    Set xlWB = xlApp.Workbooks.Open("C:\Users\xxxx\Desktop\MTR.xlsx")
    GoTo lbl_Exit
End If

Set olNS = GetNamespace("MAPI")

wb.Activate

Set xlfoldWS = wb.Worksheets("outlook folder and date")
folr = xlfoldWS.Cells(Rows.Count, 1).End(xlUp).Row

For Each cell In Range(Cells(2, 1), Cells(folr, 1))

foldstr = cell.Text
oFolderstr = Cells(cell.Row, 2).Text
Dim olFolder As Folder

For Each Folder In olNS.Folders
If InStr(Folder, foldstr) > 0 Then
Set olFolder = Folder

 For i = olFolder.Folders.Count To 1 Step -1
 Set oFolder = olFolder.Folders(i)
 If Folder & "-" & oFolder = cell.Offset(, 2).Text Then

Set olItems = oFolder.Items
 olItems.Sort "[ReceivedTime]", True


w = 1

On Error Resume Next

wb.Activate
Set xlWS = wb.Worksheets("MTR")

If wb.Worksheets("MTR").Range("A1") = "" Then

wb.Worksheets("MTR").Range("A1").Resize(1, UBound(arrHeader) + 1).Value = arrHeader
End If

lr = xlWS.Cells(Rows.Count, 1).End(xlUp).Row

w = lr
s = 1
c = 0

Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = vbTextCompare

For Each olMailItem In olItems

dic.Add s & "|" & olItems(s).ReceivedTime & "|" & olItems(s).ConversationID & "|" &     olItems(s).SenderName & "|" & olItems(s).To & "|" & olItems(s).CC & "|" & olItems(s).Categories, ""

' xlW.Cells(w + 1, "A").Value = olItems(s).ReceivedTime
'xlW.Cells(w + 1, "B").Value = olItems(s).Subject
' xlW.Cells(w + 1, "C").Value = olItems(s).ConversationID
' xlW.Cells(w + 1, "D").Value = olItems(s).SenderName
' xlW.Cells(w + 1, "E").Value = olItems(s).To
'xlW.Cells(w + 1, "F").Value = olItems(s).CC
'xlW.Cells(w + 1, "G").Value = olItems(s).Categories


s = s + 1
w = w + 1


Next olMailItem
nextfolder:

xlWS.Cells(2, 1).Resize(UBound(dic.Keys), 1).Value = Application.Transpose(dic.Keys)

xlWS.Cells.EntireColumn.AutoFit


End If


Next
End If

Next
Next cell
MsgBox "Export complete.", vbInformation
Set xlWB = Nothing
Set xlApp = Nothing

Set olItems = Nothing
Set olFolder = Nothing
Set olNS = Nothing

lbl_Exit:
Set xlApp = Nothing
Set xlWB = Nothing


End Sub
4

2 回答 2

0

听起来您想将列转移到行。那正确吗？有很多方法可以做到这一点。我觉得我需要更多信息才能做出充分知情的决定。请显示您正在尝试执行的操作的前后屏幕截图。同时，请随意尝试下面的小脚本。希望它基本上可以满足您的需求，或者它可以让您更接近您的目标。

Sub CombineColumns1()
    Dim xRng As Range
    Dim i As Long, j As Integer
    Dim xNextRow As Long
    Dim xTxt As String
    On Error Resume Next
    With ActiveSheet
        xTxt = .RangeSelection.Address
        Set xRng = Application.InputBox("please select the data range", "Kutools for Excel", xTxt, , , , , 8)
        If xRng Is Nothing Then Exit Sub
        j = xRng.Columns(1).Column
        For i = 4 To xRng.Columns.Count Step 3
            'Need to recalculate the last row, as some of the final columns may not have data in all rows
            xNextRow = .Cells(.Rows.Count, j).End(xlUp).Row + 1

            .Range(xRng.Cells(1, i), xRng.Cells(xRng.Rows.Count, i + 2)).Copy .Cells(xNextRow, j)
            .Range(xRng.Cells(1, i), xRng.Cells(xRng.Rows.Count, i + 2)).Clear
        Next
    End With
End Sub

前：

在此处输入图像描述

后：

在此处输入图像描述

于 2020-05-03T15:51:00.590 回答
0

在 Scott 之后，我使用字典和集合修改了代码

Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = vbTextCompare
Dim omail As clsomail
Dim coll As Collection
Dim key As Variant



w = 1

On Error Resume Next

Xlwb.Activate
Set xlWS = Xlwb.Worksheets("MTR")

If Xlwb.Worksheets(excelfilename).Range("A1") = "" Then
Xlwb.Worksheets(excelfilename).Range("A1").Resize(1, UBound(arrHeader) + 1).Value = arrHeader
End If
lr = xlWS.Cells(Rows.Count, 1).End(xlUp).Row

w = lr

For Each olMailItem In olItems

If olMailItem.Class = olMail Then


Set coll = New Collection
dic.Add d, coll

Set omail = New clsomail

clsomail.d = d
omail.Rec = olMailItem.ReceivedTime
omail.Subj = olMailItem.Subject
omail.Con = olMailItem.ConversationID
omail.Send = olMailItem.SenderName
omail.ToA = olMailItem.To
omail.CC = olMailItem.CC
omail.Cat = olMailItem.Categories

coll.Add omail

d = d + 1

End If

Next olMailItem


i = 2
For Each key In dic
xlWS.Cells(i, 1) = key
Set coll = dic(key)


For Each omail In coll


xlWS.Cells(i, 2) = CDate(omail.Rec)
xlWS.Cells(i, 3) = omail.Subj
xlWS.Cells(i, 4) = omail.Con
xlWS.Cells(i, 5) = omail.Send
xlWS.Cells(i, 6) = omail.ToA
xlWS.Cells(i, 7) = omail.CC
xlWS.Cells(i, 8) = omail.Cat



i = i + 1
Next omail

Next
Set coll = Nothing
Set omail = Nothing

我使用了一个类模块来定义数据的类型

Public s As Long
Public Rec As String
Public Subj As String
Public Con As String
Public Send As String
Public ToA As String
Public CC As String
Public Cat As String
Public Cou As String

这里有两个有用的链接

https://excelmacromastery.com/vba-dictionary/ https://excelmacromastery.com/vba-class-modules/

于 2020-05-11T09:25:30.847 回答