VBA：将字典转换为数组以加快处理速度答案

【问题标题】：VBA: Converting Dictionary into Array to speed processVBA：将字典转换为数组以加快处理速度
【发布时间】：2020-10-05 20:37:36
【问题描述】：

我创建了一个包含 4000 多个键和多个项目的字典，但是将这个字典传递到工作表上非常耗时且效率低下。我对此进行了研究，似乎传递给数组然后字典会更快，因为使用内存是有意义的。

使用下面的方法调用过程。

Sub Dictionary()

Dim dict As Dictionary

Set dict = ReadData()

Call WriteDict(dict)

End Sub

这将创建字典并填充自定义类模块

Function ReadData()


Dim dict As New Dictionary

Dim DataWs As Worksheet: Set DataWs = ThisWorkbook.Sheets("DATA")
Dim PoolOfWeekWs As Worksheet: Set PoolOfWeekWs = ThisWorkbook.Sheets("Pool of the week")

Dim range As range: Set range = DataWs.range("A1").CurrentRegion

Dim i As Long
Dim CandidateProcessID As String, CandidateName As String, FirstName As String, ProcessStatus As String, FirstITWDate As String, PQLDate As String, XP As String, oCandidate As ClsCandidate

For i = 2 To range.Rows.Count
    If range.Cells(i, 35).Value <> "NOK" Then
    
        ProcessStatus = range.Cells(i, 9).Value
        If range.Cells(i, 13).Value = "Prequalification" Then PQLDate = range.Cells(i, 11).Value
        ProcessType = range.Cells(i, 35).Value
        InterviewScore = range.Cells(i, 37).Value
        CandidateName = range.Cells(i, 16).Value
        FirstName = range.Cells(i, 17).Value
        NameofCM = range.Cells(i, 44).Value
        If range.Cells(i, 13) = "Candidate Interview 1" Then FirstITWDate = range.Cells(i, 11).Value
        BM1ITW = range.Cells(i, 44).Value
        DetailedSkills = range.Cells(i, 28).Value
        SkillsSummary = range.Cells(i, 29).Value
        Sector = range.Cells(i, 49).Value
        XP = range.Cells(i, 24).Value
        NP = range.Cells(i, 30).Value
        Nationality = range.Cells(i, 39).Value
        SalaryExpectation = range.Cells(i, 48).Value
        ProposedSalary = range.Cells(i, 48).Value
        If range.Cells(i, 13) = "Candidate Interview 2+" Then SecondITWDate = range.Cells(i, 11).Value
        If range.Cells(i, 13) = "Candidate Interview 2*" Then PPLDate = range.Cells(i, 11).Value
        Email = range.Cells(i, 18).Value
        PhoneNum = range.Cells(i, 19).Value
        ROName = range.Cells(i, 46).Value
        'BusinessUnitName
        'RecruitmentOfficerBusinessUnit
        'RecruiterTreegram
        'LookupyearsExperience
        
        CandidateProcessID = range.Cells(i, 10).Value
        
        If range.Cells(i, 13) = "Signature Interview" Then SignatureInterview = range.Cells(i, 11).Value
             
    If dict.Exists(CandidateProcessID) = True Then
        Set oCandidate = dict(CandidateProcessID)
        
        oCandidate.ProcessStatus = oCandidate.ProcessStatus
        oCandidate.PQLDate = oCandidate.PQLDate
        oCandidate.ProcessType = oCandidate.ProcessType
        oCandidate.InterviewScore = oCandidate.InterviewScore
        oCandidate.CandidateName = oCandidate.CandidateName
        oCandidate.FirstName = oCandidate.FirstName
        oCandidate.NameofCM = oCandidate.NameofCM
        oCandidate.FirstITWDate = oCandidate.FirstITWDate
        oCandidate.BM1ITW = oCandidate.BM1ITW
        oCandidate.DetailedSkills = oCandidate.DetailedSkills
        oCandidate.SkillsSummary = oCandidate.SkillsSummary
        oCandidate.Sector = oCandidate.Sector
        oCandidate.YearsExp = oCandidate.YearsExp
        oCandidate.NP = oCandidate.NP
        oCandidate.Nationality = oCandidate.Nationality
        oCandidate.SalaryExpectation = oCandidate.SalaryExpectation
        oCandidate.ProposedSalary = oCandidate.ProposedSalary
        oCandidate.SecondITWDate = oCandidate.SecondITWDate
        oCandidate.PPLDate = oCandidate.PPLDate
        oCandidate.Email = oCandidate.Email
        oCandidate.PhoneNum = oCandidate.PhoneNum
        oCandidate.ROName = oCandidate.ROName
       
    Else
        Set oCandidate = New ClsCandidate
        dict.Add CandidateProcessID, oCandidate
        
        oCandidate.ProcessStatus = oCandidate.ProcessStatus + ProcessStatus
        oCandidate.PQLDate = oCandidate.PQLDate + PQLDate
        oCandidate.ProcessType = oCandidate.ProcessType + ProcessType
        oCandidate.InterviewScore = oCandidate.InterviewScore + InterviewScore
        oCandidate.CandidateName = oCandidate.CandidateName + CandidateName
        oCandidate.FirstName = oCandidate.FirstName + FirstName
        oCandidate.NameofCM = oCandidate.NameofCM + NameofCM
        oCandidate.FirstITWDate = oCandidate.FirstITWDate + FirstITWDate
        oCandidate.BM1ITW = oCandidate.BM1ITW + BM1ITW
        oCandidate.DetailedSkills = oCandidate.DetailedSkills + DetailedSkills
        oCandidate.SkillsSummary = oCandidate.SkillsSummary + SkillsSummary
        oCandidate.Sector = oCandidate.Sector + Sector
        oCandidate.YearsExp = oCandidate.YearsExp + YearsExp
        oCandidate.NP = oCandidate.NP + NP
        oCandidate.Nationality = oCandidate.Nationality + Nationality
        oCandidate.SalaryExpectation = oCandidate.SalaryExpectation + SalaryExpectation
        oCandidate.ProposedSalary = oCandidate.ProposedSalary + ProposedSalary
        oCandidate.SecondITWDate = oCandidate.SecondITWDate + SecondITWDate
        oCandidate.PPLDate = oCandidate.PPLDate + PPLDate
        oCandidate.Email = oCandidate.Email + Email
        oCandidate.PhoneNum = oCandidate.PhoneNum + PhoneNum
        oCandidate.ROName = oCandidate.ROName + ROName
    End If
    
    End If

Next i

Set ReadData = dict


End Function

下面将数据写入工作表

Sub WriteDict(dict As Dictionary)

Application.ScreenUpdating = False

    Dim key, DictOutput() As Variant, oCandidate As ClsCandidate, row, TotalEntries, TotalColumns As Long, OutputRange As range
    Set rangeoutput = Sheets("Pool of the week")
    row = 1
    
    TotalEntries = dict.Count
    TotalColumns = 22
    DictOutput = dict.Items()
    
Application.ScreenUpdating = True

End Sub

首先，我尝试使用上述方法将字典传递给数组。但是，它不会以与字典相同的顺序（按字母顺序）从类模块中添加字典项，这是我首先创建字典以重新排列它们的原因之一。

是否可以让数组保持与字典相同的格式，如果是，那么现在传递给工作表的最佳方式是什么？会不会是

'Psuedo code
Sheets(SHEETNAME).Range("A1").Resize(UBound(DictOutput(1)) = DictOutput

评论后 如屏幕截图所示，数组似乎是一维的。也不按正确顺序 Screenshot of Array Crated from Dictionary

回答后编辑

For i = 2 To range.Rows.Count
    If range.Cells(i, 35).Value <> "NOK" Then
    
        If range.Cells(i, 13) = "Candidate Interview 1" Then FirstITWDate = range.Cells(i, 11).Value: BM1ITW = range.Cells(i, 5).Value
        If range.Cells(i, 49) = "Expected Gross Annual Salary" Then SalaryExpectation = range.Cells(i, 50).Value ' If column x is salary expectation take this value
        If range.Cells(i, 49) = "Proposed Gross Annual Salary (AHF)" Then ProposedSalary = range.Cells(i, 50).Value 'if column x is proposed take this value
        If range.Cells(i, 13) = "Candidate Interview 2+" Then SecondITWDate = range.Cells(i, 11).Value
        If range.Cells(i, 13) = "Candidate Interview 2*" Then PPLDate = range.Cells(i, 11).Value
        If range.Cells(i, 13).Value = "Prequalification" Then PQLDate = range.Cells(i, 11).Value
        If range.Cells(i, 13) = "Signature Interview" Then SignatureInterview = range.Cells(i, 11).Value
        
        CandidateProcessID = range.Cells(i, 10).Value
        ProcessStatus = range.Cells(i, 9).Value
        ProcessType = range.Cells(i, 35).Value
        InterviewScore = range.Cells(i, 37).Value
        CandidateName = range.Cells(i, 16).Value
        FirstName = range.Cells(i, 17).Value
        NameofCM = range.Cells(i, 44).Value
        DetailedSkills = range.Cells(i, 28).Value
        SkillsSummary = range.Cells(i, 29).Value
        Sector = range.Cells(i, 48).Value
        XP = range.Cells(i, 24).Value
        NP = range.Cells(i, 30).Value
        Nationality = range.Cells(i, 39).Value
        Mobility = range.Cells(i, 47).Value
        Email = range.Cells(i, 18).Value
        PhoneNum = range.Cells(i, 19).Value
        ROName = range.Cells(i, 46).Value
        
        'BusinessUnitName
        'RecruitmentOfficerBusinessUnit
        'RecruiterTreegram
        'LookupyearsExperience
        
        
        
        If dict.Exists(CandidateProcessID) = True Then
            Set oCandidate = dict(CandidateProcessID)
                oCandidate.ProcessStatus = ProcessStatus
                oCandidate.PQLDate = PQLDate
                oCandidate.ProcessType = ProcessType
                oCandidate.InterviewScore = InterviewScore
                oCandidate.CandidateName = CandidateName
                oCandidate.FirstName = FirstName
                oCandidate.NameofCM = NameofCM
                oCandidate.FirstITWDate = FirstITWDate
                oCandidate.BM1ITW = BM1ITW
                oCandidate.DetailedSkills = DetailedSkills
                oCandidate.SkillsSummary = SkillsSummary
                oCandidate.Sector = Sector
                oCandidate.YearsExp = YearsExp
                oCandidate.NP = NP
                oCandidate.Nationality = Nationality
                oCandidate.Mobility = Mobility
                oCandidate.SalaryExpectation = SalaryExpectation
                oCandidate.ProposedSalary = ProposedSalary
                oCandidate.SecondITWDate = SecondITWDate
                oCandidate.PPLDate = PPLDate
                oCandidate.Email = Email
                oCandidate.PhoneNum = PhoneNum
                oCandidate.ROName = ROName
        Else
            Set oCandidate = New ClsCandidate

                oCandidate.ProcessStatus = ProcessStatus
                oCandidate.PQLDate = PQLDate
                oCandidate.ProcessType = ProcessType
                oCandidate.InterviewScore = InterviewScore
                oCandidate.CandidateName = CandidateName
                oCandidate.FirstName = FirstName
                oCandidate.NameofCM = NameofCM
                oCandidate.FirstITWDate = FirstITWDate
                oCandidate.BM1ITW = BM1ITW
                oCandidate.DetailedSkills = DetailedSkills
                oCandidate.SkillsSummary = SkillsSummary
                oCandidate.Sector = Sector
                oCandidate.YearsExp = YearsExp
                oCandidate.NP = NP
                oCandidate.Nationality = Nationality
                oCandidate.Mobility = Mobility
                oCandidate.SalaryExpectation = SalaryExpectation
                oCandidate.ProposedSalary = ProposedSalary
                oCandidate.SecondITWDate = SecondITWDate
                oCandidate.PPLDate = PPLDate
                oCandidate.Email = Email
                oCandidate.PhoneNum = PhoneNum
                oCandidate.ROName = ROName
        
            dict.Add CandidateProcessID, oCandidate
        End If
        
    End If

Next i

【问题讨论】：

您不能像这样将自定义对象数组写入工作表：您需要遍历数组，逐个提取每个对象的属性，然后将它们写入行为那个对象。
为什么需要使用自定义类？
@TimWilliams 循环数组是否会比将字典打印到工作表更昂贵？这将是一个大数组
你别无选择。
FYI in ReadData 你仍然犯了与上一篇文章相同的错误：stackoverflow.com/questions/64125396/… 如果字典中有一个现有的候选者，那么你只需将对象属性设置为它们的当前值（基本上什么都不做）。但是，当您创建一个新对象时，您 add 到现有属性（此时将全部为 empty）

标签： arrays excel vba dictionary

【解决方案1】：

解决您填充字典的方式：您的逻辑不正确，应该是这样的：

loop over lines
    read data from the line
    if object with line's "key" exists in the dictionary
        get reference to existing object from dictionary
        append additional information to the object's properties
    else
        create new object
        populate properties
        add to dictionary
    end if
next line

【讨论】：

好的，我正在尝试剥离代码以了解逻辑。但到目前为止，解决方案正在逃避我。到目前为止，我认为我正在做的是查看键是否存在，如果存在，则附加值。如果没有，请添加键，然后附加值。解决方案是如果存在，不添加，否则将键添加到字典，如果结束，然后附加所有数据？请参阅编辑以供参考
仅供参考，我知道有问题，因为在输入工作表时数据是正确的一半。一些数据替换为另一个候选人信息，所以我知道你是对的