excel - 创建一个 VBA 版本的字典，每个键有 2 个值

Question

我正在尝试使我的 excel 宏动态化。 excel 宏本质上只查看两列，一列包含名称，另一列包含数字部分。我的宏运行良好，唯一的问题是在我创建程序时它是硬编码的。在我的代码中，我硬编码了第 2 列中的名称和第 3 列中的数字部分。但是，在现实生活中并非如此。例如，名称和数字数据可能出现在第 1 列和第 5 列中。我一直在手动重新排列列中的数据，以使其适合硬编码的内容。但是，我想让这个过程动态化，减少用户的手动工作。

该宏将用于 5 个不同版本的电子表格，并且在每个电子表格中，名称和编号列都不同。我正在寻找某种形式的用户表单框，用户在其中选择“供应商 XYZ”，并且由于供应商 XYZ 总是以同样的方式发送他们的数据表，我知道供应商 XYZ 的名称列是 2，数字是 4。所以我是认为字典将是 {Vendor XYZ: 2,4} 形式的东西(其中第一个数字是名称列，第二个数字是数字列号......我知道语法错误)

我认为我的解决方法是对不同的供应商进行硬编码，然后使用 if 语句(我还没有尝试过)

我将有一个包含 5 个不同供应商的用户输入/下拉框。然后像

If userinput="A" 
then namecol=2 and numcol=1
If userinput="B" 
then namecol="3" and numcol="4" 

我不知道这是否会奏效。问题是现在供应商的数量很少，但会扩大规模，如果我们有 100 或 1000 个供应商，我就无法做到这一点。
有任何想法吗？

Answer 1

根据检索初始数据集的方式，您可以使用以下内容:

Public Function GetHeaderIndices(ByVal InputData As Variant) As Scripting.Dictionary
    If IsEmpty(InputData) Then Exit Function

    Dim HeaderIndices As Scripting.Dictionary
    Set HeaderIndices = New Scripting.Dictionary

    HeaderIndices.CompareMode = TextCompare

    Dim i As Long
    For i = LBound(InputData, 2) To UBound(InputData, 2)
        If Not HeaderIndices.Exists(Trim(InputData(LBound(InputData, 1), i))) Then _
           HeaderIndices.Add Trim(InputData(LBound(InputData, 1), i)), i
    Next

    Set GetHeaderIndices = HeaderIndices
End Function

这个Function将一个数组作为输入，并为用户提供一个字典，其中包含输入中标题的索引。

如果你很聪明(我这么说是因为太多的用户只是不使用表)你将把你的数据放在一个表中，并且你会为那个表命名。如果你这样做了，你可以这样做:

Sub DoSomething()
    Dim MyData as Variant
    MyData = ThisWorkbook.Worksheets("MyDataSheet").ListObjects("MyTableName").Range.Value
End Sub

因此，如果您的数据如下所示:

Foo    Baz    Bar

1      Car    Apple
3      Van    Orange
2      Truck  Banana

该函数会给你一个字典，如:

Keys        Items

Foo         1
Baz         2
Bar         3

然后你的子程序可以做这样的事情:

Sub DoEverything()
    Dim MyData as Variant
    MyData = ThisWorkbook.Worksheets("MyDataSheet").ListObjects("MyTableName").Range.Value

    DoSomething(MyData)
End Sub


Sub DoSomething(ByRef MyData as Variant)
    Dim HeaderIndices as Scripting.Dictionary
    Set HeaderIndices = GetHeaderIndices(MyData)

    Dim i as Long

    ' Loop through all the rows after the header row.
    For i = LBound(MyData, 1) + 1 to Ubound(MyData, 1)
        If MyData(i, HeaderIndices("Baz")) = "Truck" Then
            ?MyData(i, HeaderIndices("Foo"))
            ?MyData(i, HeaderIndices("Baz"))
            ?MyData(i, HeaderIndices("Bar"))
        End If
    Next
End Sub

这确实需要对 Scripting.Runtime 的引用，因此如果您不想添加引用，则需要更改对 As Scripting.Dictionary 的任何引用。至As Object和任何 New Scripting.Dictionary至CreateObject("Scripting.Dictionary") .

或者，我使用以下代码模块以编程方式为我的所有用户添加引用:

Public Sub PrepareReferences()
    If CheckForAccess Then
        RemoveBrokenReferences
        AddReferencebyGUID "{420B2830-E718-11CF-893D-00A0C9054228}"
    End If
End Sub

Public Sub AddReferencebyGUID(ByVal ReferenceGUID As String)
    Dim Reference As Variant
    Dim i As Long

    ' Set to continue in case of error
    On Error Resume Next

    ' Add the reference
    ThisWorkbook.VBProject.References.AddFromGuid _
        GUID:=ReferenceGUID, Major:=1, Minor:=0

    ' If an error was encountered, inform the user
    Select Case Err.Number
    Case 32813
        ' Reference already in use.  No action necessary
    Case vbNullString
        ' Reference added without issue
    Case Else
        ' An unknown error was encountered, so alert the user
        MsgBox "A problem was encountered trying to" & vbNewLine _
             & "add or remove a reference in this file" & vbNewLine & "Please check the " _
             & "references in your VBA project!", vbCritical + vbOKOnly, "Error!"
    End Select
    On Error GoTo 0
End Sub

Private Sub RemoveBrokenReferences()
    ' Reference is a Variant here since it requires an external reference.
    ' It isnt possible to ensure that the external reference is checked when this process runs.
    Dim Reference As Variant
    Dim i As Long

    For i = ThisWorkbook.VBProject.References.Count To 1 Step -1
        Set Reference = ThisWorkbook.VBProject.References.Item(i)
        If Reference.IsBroken Then
            ThisWorkbook.VBProject.References.Remove Reference
        End If
    Next i
End Sub

Public Function CheckForAccess() As Boolean
    ' Checks to ensure access to the Object Model is set
    Dim VBP As Variant
    If Val(Application.Version) >= 10 Then
        On Error Resume Next
        Set VBP = ThisWorkbook.VBProject
        If Err.Number <> 0 Then
            MsgBox "Please pay attention to this message." _
                 & vbCrLf & vbCrLf & "Your security settings do not allow this procedure to run." _
                 & vbCrLf & vbCrLf & "To change your security setting:" _
                 & vbCrLf & vbCrLf & " 1. Select File - Options - Trust Center - Trust Center Settings - Macro Settings." & vbCrLf _
                 & " 2. Place a checkmark next to 'Trust access to the VBA project object model.'" _
                 & vbCrLf & "Once you have completed this process, please save and reopen the workbook." _
                 & vbCrLf & "Please reach out for assistance with this process.", _
                   vbCritical
            CheckForAccess = False
            Err.Clear
            Exit Function
        End If
    End If
    CheckForAccess = True
End Function

我在每个 Workbook_Open 中都有以下命令事件(不太理想，但到目前为止我只有一个好的解决方案)

Private Sub Workbook_Open()
    PrepareReferences
End Sub