创建一个VBA版本的字典，每个键值为2个

Question

我想让我的excel宏变为动态。 excel宏本质上只查看2列，一列包含名称，另一列包含数字部分。我有我的宏完美工作，唯一的问题是，当我创建程序时，它是硬编码。在我的代码中，我硬编码了第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