在excel表格中转置长255的字典键

最后发布: 2020-07-09


问题

我需要在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
excel vba dictionary
回答

听起来你是想把列转为行。 是这样吗? 有这么多方法可以做到这一点。 我觉得我需要更多的信息才能做出一个完全明智的决定。 请显示一个前&后的屏幕截图,你正在尝试做什么。 同时,请随意尝试下面的小脚本。 希望它能做到你想要的,基本上,或者它能让你更接近你的目标。

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

Before:之前

enter image description here

After:

enter image description here


回答

跟随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.comvba-dictionaryhttps:/excelmacromastery.comvba class-modules。