Мне нужно записать в разные столбцы таблицы Excel данные (такие как отправитель, дата получения, тема и т. Д.) Многих электронных писем Outlook. Я могу сделать это, сообщая о каждой электронной почте данные в соответствующей ячейке, но производительность довольно низкая. Моя идея состоит в том, чтобы сохранить данные электронных писем в словарных (di c) ключах, а затем перенести эти данные в таблицу 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