創建一個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