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

我正在努力使我的Excelmacros观dynamic。 excelmacros本质上只看2列，一列包含名称，另一列包含数字部分。 我有我的macros完美工作，唯一的问题是，当我创build程序时，它是硬编码。 在我的代码中，我在第2列中将名称硬编码，在第3列中将数字部分硬编码。但是，在现实生活中并非如此。 例如，名称和数字数据可以出现在第1列和第5列中。 我已经手动重新排列列中的数据，以适应硬编码。 不过，我想让这个过程变得dynamic，为用户减less手动工作。

这个macros有5个不同版本的电子表格，每个电子表格中的名称和编号列是不同的。 我正在寻找一个用户表单框，其中用户select“供应商XYZ”，因为供应商XYZ总是发送他们的数据表，我知道供应商XYZ的名字栏是2和数字是4.所以我是认为字典是{Vendor XYZ：2,4}forms的（第一个数字是名字列，第二个数字是数字列号…我知道这个语法是错误的）

我想我的工作是硬编码不同的供应商，然后使用if语句（我还没有尝试过）

我将有一个用户input/下拉框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将一个数组作为input，并为用户提供一个字典，其中包含来自输​​入的标题索引。

如果你很聪明 （我这样说，因为太多的用户不使用表），你会有你的数据在一个表中，你将命名该表。 如果你这样做，你可以做这样的事情：

 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事件中都有以下命令（不太理想，但目前为止我只有很好的解决scheme）

 Private Sub Workbook_Open() PrepareReferences End Sub