创建数组字典

Question

我的输入文件(纯文本文件)如下：

tom:ss1:ts1
dick:ss1:ts1
tom:ss2:ts2
dick:ss2:ts2
harry:ss1:ts1
tom:ss3:
harry::ts2

第一列是员工姓名。第二类是软技能培训，第三类是技术技能培训。

我想读取这个文件并创建下面的结构“在内存中”，以便在后面的代码中使用。

{
'dick': {
            'soft_skill': ['ss1', 'ss2'], 
            'tech_skill': ['ts1', 'ts2']
        }, 
'harry': {
            'soft_skill': ['ss1'], 
            'tech_skill': ['ts1', 'ts2']
        }, 
'tom': {
            'soft_skill': ['ss1', 'ss2', 'ss3'], 
            'tech_skill': ['ts1', 'ts2']
        }
}

相对于键'tom‘，存储的值是一个字典，如下所示：

{
  'soft_skill': ['ss1', 'ss2', 'ss3'], 
  'tech_skill': ['ts1', 'ts2']
}

在此字典中，相对于键'soft_skill'，值是一个数组，显示为'ss1'，'ss2'，'ss3‘。

类似于'soft_skill'，键'tech_skill‘将值保存为一个数组，显示为'ts1'，'ts2’。

如何在VBA中创建上述结构？

我已经使用FSO将文本读取到excel中，并将col1的命名范围定义为"name_rng“，该命名范围继续如下：

Set traininglist = CreateObject("Scripting.Dictionary")
For Each cell In Range("name_rng")
   If Not traininglist.Exists(cell.Value) Then
      traininglist.Add cell.Value, Cells(cell.Row, 2).Value & ";" & _ 
         Cells(cell.Row, 3).Value
   Else
     traininglist(cell.Value) = traininglist(cell.Value) & "|" & _
     Cells(cell.Row, 2).Value & ";" & Cells(cell.Row, 3).Value
End If
Next
x = traininglist.keys
y = traininglist.items

For i = 0 To UBound(x)
    ActiveCell.Value = x(i)
    ActiveCell.Offset(0, 1).Value = y(i)
    ActiveCell.Offset(1, 0).Select
Next
Set traininglist = Nothing
end sub

这就是我将值存储为(key，value)对的方式

tom => ss1;ts1|ss2;ts2|ss3;   

dick => ss1;ts1|ss2;ts2

harry => ss1;ts1|;ts2

例如，取'tom‘的值，'ss1;ts1’是软技能和技术技能的第一个集合，然后用|进一步分隔，以便在各个emp的其他训练集合之间进行分隔。

上面的方法已经足够了，但我必须根据分隔符进一步拆分值，并使用循环来访问值……我认为这是一种变通方法，但不是身份验证解决方案...

因此需要建议如何创建数组字典的字典。

Answer 1

可以使用Data Types和arrays来实现该任务，请参阅代码中的注释。但是，如果您仍然希望使用Dictionary，则可以使用collection (或嵌套集合)作为字典的值：Create dictionary of lists in vba

Type Employee
 soft_skill() As Variant
 tech_skill() As Variant
 name As String
End Type

Function GetEmployee(ByVal name As String, ByRef soft_skill As Variant, ByRef tech_skill As Variant) As Employee
GetEmployee.name = name
GetEmployee.soft_skill = soft_skill
GetEmployee.tech_skill = tech_skill
End Function


Sub Main()

' declare an array of 2 Employee for the example
Dim ar(1) As Employee

' add "TOM"
Dim soft_skill As Variant
soft_skill = Array("ss1", "ss2", "ss3")
Dim tech_skill As Variant
tech_skill = Array("ts1", "ts2")
ar(0) = GetEmployee("TOM", soft_skill, tech_skill)

' add "JOHN"
Dim soft_skill2 As Variant
soft_skill2 = Array("vb.net", "c++", "java")
Dim tech_skill2 As Variant
tech_skill2 = Array("c#", "vba")
ar(1) = GetEmployee("JOHN", soft_skill2, tech_skill2)

' loop trough the array
For i = 0 To UBound(ar)
MsgBox (ar(i).name & " ")
    ' show soft_skill
    For j = 0 To UBound(ar(i).soft_skill)
        MsgBox (ar(i).soft_skill(j))
    Next j
    ' show tech_skill
    For Z = 0 To UBound(ar(i).tech_skill)
        MsgBox (ar(i).tech_skill(Z))
    Next Z
Next i

' use like a dictionary (get TOM for example)
Dim p As Employee
p = pickEmp("TOM", ar)
' show tom name
MsgBox (p.name)
' show tom soft_skills
For i = 0 To UBound(p.soft_skill)
    MsgBox (p.soft_skill(i))
Next
' show tom tech_skill
For i = 0 To UBound(p.tech_skill)
    MsgBox (p.tech_skill(i))
Next

End Sub

' return employee by name parameter from employee array
Private Function pickEmp(ByVal name As String, ByRef empArray() As Employee) As Employee

   Dim index As Integer
   index = -1

    For i = 0 To UBound(empArray)
        If empArray(i).name = name Then
            index = i
            Exit For
        End If
    Next i

   If index = -1 Then
       MsgBox ("there is no employee called " & name)
   End If

    pickEmp = empArray(index)

End Function

Answer 2

尝试执行以下宏...

Sub test()

Dim dicNames As Object
Dim dicSkills As Object
Dim strPathAndFilename As String
Dim strTextLine As String
Dim intFileNum As Integer
Dim arrData() As String
Dim strName As String
Dim strSoftSkill As String
Dim strTechSkill As String
Dim intField As Integer
Dim arr() As String
Dim i As Long

strPathAndFilename = "c:\users\domenic\desktop\sample.txt"
If Len(Dir(strPathAndFilename, vbNormal)) = 0 Then
    MsgBox "File not found.", vbExclamation
    Exit Sub
End If

Set dicNames = CreateObject("Scripting.Dictionary")
dicNames.CompareMode = 1 'TextCompare

intFileNum = FreeFile()
Open strPathAndFilename For Input As intFileNum
    Do Until EOF(intFileNum)
        Line Input #intFileNum, strTextLine
        If Len(strTextLine) > 0 Then
            strName = ""
            strSoftSkill = ""
            strTechSkill = ""
            arrData() = Split(strTextLine, ":")
            For intField = LBound(arrData) To UBound(arrData)
                Select Case intField
                    Case 0: strName = Trim(Split(strTextLine, ":")(intField))
                    Case 1: strSoftSkill = Trim(Split(strTextLine, ":")(intField))
                    Case 2: strTechSkill = Trim(Split(strTextLine, ":")(intField))
                End Select
            Next intField
            If Not dicNames.Exists(strName) Then
                Set dicSkills = CreateObject("Scripting.Dictionary")
                dicSkills.CompareMode = 1 'TextCompare
                If Len(strSoftSkill) > 0 Then
                    dicSkills.Add "Soft_Skills", strSoftSkill
                End If
                If Len(strTechSkill) > 0 Then
                    dicSkills.Add "Tech_Skills", strTechSkill
                End If
                dicNames.Add strName, dicSkills
            Else
                If Len(strSoftSkill) > 0 Then
                    dicNames(strName).Item("Soft_Skills") = dicNames(strName).Item("Soft_Skills") & "|" & strSoftSkill
                End If
                If Len(strTechSkill) > 0 Then
                    dicNames(strName).Item("Tech_Skills") = dicNames(strName).Item("Tech_Skills") & "|" & strTechSkill
                End If
            End If
        End If
    Loop
Close intFileNum

'List soft skills for Tom
arr() = Split(dicNames("tom").Item("Soft_Skills"), "|")
If UBound(arr) <> -1 Then
    For i = LBound(arr) To UBound(arr)
        Debug.Print Trim(arr(i))
    Next i
Else
    MsgBox "No soft skills listed for Tom.", vbInformation
End If

Set dicNames = Nothing
Set dicSkills = Nothing

结束子对象