什么是在VBA中输入键值对的非常简单的方法？

Question

我写，我想下面的两个功能（伪代码）一个VBA脚本：

C5 = "Hello" 
D6 = "World" 
E2 = 23.45 
a: Place the values in the correct cell in the worksheet 
and 
b: Check if the cells contain the correct values 

我会说，从来没有在他们的生活写一个脚本来同事分享这些（但他们能够使用Excel的公式，如vlookup等）。因此，我需要能够非常简单地将单元格编号和相应的值编写在一起。

Sub NewbieProofSub 
    Set dict = CreateObject("Scripting.Dictionary") 
    dict.Add "C5", "Hello" 
    dict.Add "D6", "World" 
    dict.Add "E2", 23.45 

    ' Inserting values: 
    Dim v As Variant 
    Dim s As String 
    For Each v In dict.Keys 
     s = v 
     Range(s).Value = dict.Item(v) 
    Next 

    dict.Add "F3", 13 

    ' Checking values 
    For Each v In dict.Keys 
     s = v 
     If Range(s).Value = dict.Item(v) Then 
     MsgBox ("The value in " & s & " is " & dict.Item(v)) 
     Else 
     MsgBox ("The value in " & s & " is not " & dict.Item(v)) 
     End If 
    Next 

End Sub 

这些将被分成两个模块，但我在这里包括这两个说明。

我很满意，但我不知道是否有可能使更简单，避免所有行dict.add？例如：

' Fill this list with your desired values on the format: 
' Cell, Value (Remove the existing lines) 

dict.add { 
"C5", "Hello" 
"D6", "World" 
"E2", 23.45 
} 

是这样的可能吗？

Answer 1

我想这可以变得更简单，如果cell address和corresponding values可以写入工作表中的某个地方（未使用的列）。例如，如果单元格地址在范围O1:O3输入并在范围P1:P3对应值，则代替

dict.Add "C5", "Hello" 
dict.Add "D6", "World" 
dict.Add "E2", 23.45 

可以添加

项字典作为

Dim rng As Range, cel As Range 
Set rng = Range("O1:O3") 
For Each cel In rng 
    dict.Add cel.Value, cel.Offset(0, 1).Value 
Next cel 

，如果行数会变化，然后上述可被写为

Dim rng As Range, cel As Range 
Dim lastRow As Long 
lastRow = Cells(Rows.Count, "O").End(xlUp).Row 
Set rng = Range("O1:O" & lastRow) 
For Each cel In rng 
    dict.Add cel.Value, cel.Offset(0, 1).Value 
Next cel 

---

的这样做的另一种方式将是在另一个阵列中的一个阵列中添加阵列cell address和corresponding values作为

Dim arr1, arr2, i As Long 
arr1 = Array("C5", "D6", "E2") 
arr2 = Array("Hello", "World", "23.45") 
For i = LBound(arr1) To UBound(arr1) 
    dict.Add arr1(i), arr2(i) 
Next i 

或同时添加cell address和corresponding values一起

Dim arr, i As Long 
arr = Array("C5", "Hello", "D6", "World", "E2", "23.45") 
For i = LBound(arr) To UBound(arr) Step 2 
    dict.Add arr(i), arr(i + 1) 
Next i 

Answer 2

您还可以得到所有的信息从片，包括单元格地址

如果你有工作表Sheet1上：

C5 = "Hello" 
D6 = "World" 
E2 = 23.45 
F3 = 13 

---

Option Explicit 

Public Sub NewbieProofSub() 
    Dim d As Object, cel As Range, k As Variant, valid As String 

    Set d = CreateObject("Scripting.Dictionary") 

    For Each cel In Sheet1.UsedRange 
     If Len(cel.Value2) > 0 Then d(cel.Address(False, False)) = cel.Value2 
    Next 

    d("F3") = 15  'Change dictionary value 

    For Each k In d.Keys 
     valid = IIf(Sheet1.Range(k).Value2 <> d(k), "not ", vbNullString) 
     MsgBox "The value in " & k & " is " & valid & d(k) 
    Next 
End Sub 

---

当您试图访问一个关键的字典

• 如果该键不存在，新的对将被添加到字典中默默地

• 否则它不会创建广告uplicate关键，但其价值将被更新

Answer 3

在途中快速加载字典是创建一个名为Dictionary构造，就像Array。

你可以然后加载字典对准作为参数的按键/项目：

Set dict = Dictionary("a", 1, "b", 2, "c", 3) 

，或者与一个范围，其中键是在第一列和第二项：

Set dict = Dictionary([Sheet1!A2]) 

这里的功能，可前面的例子：

Public Function Dictionary(ParamArray args()) As Object 
    Dim i As Long, arr() 
    Set Dictionary = CreateObject("Scripting.Dictionary") 

    If UBound(args) >= 0 Then ' if has arguments ' 
    If VBA.IsObject(args(0)) Then ' if object then load a Range ' 
     arr = args(0).Resize(args(0).End(xlDown).Row - args(0).Row + 1, 2).Value 

     For i = 1 To UBound(arr) 
     Dictionary.Add arr(i, 1), arr(i, 2) 
     Next 
    Else        ' else load an Array ' 
     For i = 0 To UBound(args) Step 2 
     Dictionary.Add args(i), args(i + 1) 
     Next 
    End If 
    End If 
End Function 

Answer 4

一个W唉，要做到这一点是在你的代码的顶部声明一个常量。这样，新手不太可能破坏代码。

您可以使用任何字符要么分离，除了空间的第一个和可能出现在一个有效的文本值，无论是任何字符。

我已经展示了一些提取单元格值对的方法。删除所有If小号除了一个用于工作代码：

' Fill this list with your desired values in the format: 
' "=Cell Value" (Remove the existing lines) 

Private Const NewbieProofString As String = "" _ 
& "=C5 Hello" _ 
& "=D6 World" _ 
& "=E2 23.45" _ 
' Don't remove this line 

Sub NOT_NewbieProofSub() 

    Dim varItem As Variant 
    Dim astrItem() As String 
    Dim lngSeparatorIndex As Long 
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary") 
    For Each varItem In Split(NewbieProofString, "=") ' First separator 
     ' This if second separator = " " 
    If varItem <> vbNullString Then ' First item is always empty 
     lngSeparatorIndex = InStr(varItem, " ") 
     dict.Add Left$(varItem, lngSeparatorIndex - 1), Trim(Mid$(varItem, lngSeparatorIndex)) ' Allows extra spaces between key and value 
    End If 
     ' Or alternatively this if second separator = " " 
    If varItem <> vbNullString Then ' First item is always empty 
     astrItem = Split(WorksheetFunction.Substitute(varItem, " ", "§", 1), "§") 'Use anything NOT EVER found in your values 
     dict.Add astrItem(0), Trim(astrItem(1)) ' Allows extra spaces 
    End If 
     ' Or this if second separator anything else, e.g., ":" 
    If varItem <> vbNullString Then ' First item is always empty 
     astrItem = Split(varItem, ":") 
     dict.Add astrItem(0), Trim(astrItem(1)) ' Allows extra spaces 
    End If 
    Next varItem 

    … 

End Sub 

注声明的特殊构造，使进入每一行数据是相同的。这导致两个副作用：

• 有MUST是一个注释，或空行，立即声明之后;
• 第一个单元值项目将始终为空。

Answer 5

我想不出什么比正好包含一个 子单个模块，其中单元值对被输入就像正常的变量赋值简单：

'=============================================================================== 
' Module  : NewbieProof 
' Version : 1.0 
' Part  : 1 of 3 
' References : N/A 
' Online  : https://stackoverflow.com/a/46068523/1961728 
'=============================================================================== 
Sub SuperNewieProofData() 

' Fill this list with your desired values in the format: 
' Cell = Value (Remove the existing lines) 

C5 = "Hello" 
D6 = "World" 
E2 = 23.45 

End Sub 

---

启用通过VBA IDE对象本身，这个成功使用的子需要一点魔力。认为自我修改的代码。在这种情况下，只有的代码读取来自NewbieProof模块的子部分，提取单元值对。

这片神奇的被封装在辅助功能TheNewbieDict()返回完全填充的词典：

'=============================================================================== 
' Module  : <in any standard module> 
' Version : 1.0 
' Part  : 2 of 3 
' References : Microsoft Visual Basic For Applications Extensibility 5.3 
' Online  : https://stackoverflow.com/a/46068523/1961728 
'=============================================================================== 
Private Const l_Error As String = "Error" 

Function TheNewbieDict() As Object 

    Const l_NewbieProof As String = "NewbieProof" 

    Dim e_Proc As VBIDE.vbext_ProcKind: e_Proc = VBIDE.vbext_ProcKind.vbext_pk_Proc 
    Dim vbprojThis As VBIDE.VBProject 
    Dim codeNewbieProof As VBIDE.CodeModule 
    Dim strProcName As String 
    Dim lngLineNumber As Long 
    Dim strCurrentLine As String 
    Dim strNewbieCell As String 
    Dim strNewbieValue As String 

    ' Add reference to "Microsoft Visual Basic For Applications Extensibility 5.3" 
    On Error Resume Next 
    ThisWorkbook.VBProject.References.AddFromGuid GUID:="{0002E157-0000-0000-C000-000000000046}", Major:=5, Minor:=3 
    On Error GoTo 0 
    Set TheNewbieDict = CreateObject("Scripting.Dictionary") 
    Set vbprojThis = ActiveWorkbook.VBProject 
    On Error Resume Next: Set codeNewbieProof = vbprojThis.VBComponents(l_NewbieProof).CodeModule: On Error GoTo 0 
    If codeNewbieProof Is Nothing Then 
    TheNewbieDict.Add l_Error, 1& 
    Exit Function 
    End If 
    With codeNewbieProof 
    If .CountOfLines = .CountOfDeclarationLines Then 
     TheNewbieDict.Add l_Error, 2& 
     Exit Function 
    End If 
    strProcName = .ProcOfLine(.CountOfDeclarationLines + 1, e_Proc) 
    lngLineNumber = .ProcBodyLine(strProcName, e_Proc) 
    Do Until lngLineNumber >= .CountOfLines: Do 
     lngLineNumber = lngLineNumber + 1 
     strCurrentLine = .Lines(lngLineNumber, 1) 
     ' Skip comment and empty lines 
     If Left$(Trim(strCurrentLine), 1) & "'" Like "'*" Then Exit Do 
     ' Skip non-assignment lines ("Function …" and "End Function" lines) 
     If Not strCurrentLine Like "*=*" Then Exit Do 
     ' Extract the Cell-Value pair from the line 
     strNewbieCell = Trim(Replace(Left$(strCurrentLine, InStr(strCurrentLine, "=") - 1), """", "")) 
     strNewbieValue = Trim(Replace(Mid$(strCurrentLine, InStr(strCurrentLine, "=") + 1), """", "")) 
     If Not TheNewbieDict.Exists(strNewbieCell) Then 
     TheNewbieDict.Add strNewbieCell, strNewbieValue 
     End If 
    Loop While 0: Loop 
    If TheNewbieDict.Count = 0 Then 
     TheNewbieDict.Add l_Error, 3& 
     Exit Function 
    End If 
    End With 

End Function 

---

这是你会怎么称呼它：

'=============================================================================== 
' Module  : <in any standard module> 
' Version : 1.0 
' Part  : 3 of 3 
' References : N/A 
' Online  : https://stackoverflow.com/a/ 
'=============================================================================== 
Sub NOT_NewbieProofSub() 

    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary") 
    Set dict = TheNewbieDict() 
    If dict.Exists(l_Error) Then 
    ' Error creating dictionary - Some newbie deleted/renamed/cleared 
    ' or otherwise messed with the NewbieProof code module. 
    MsgBox _ 
     "Oops! Not so newbie-proof!" & vbCrLf & vbCrLf _ 
     & "Looks like some Newbie " _ 
     & Choose(dict("Error"), "renamed or delete", "deleted the sub in", "deleted the data from") _ 
     & " the NewbieProof code module." & vbCrLf & vbCrLf _ 
     & "Please contact your local Code Guru." _ 
     , vbCritical 
    Exit Sub 
    End If 

    '… 

End Sub 

---

如果你想把所有的东西放在一个模块中，使用相同的技术，你可以在下面放置该模块的最顶部，并将它自动加载到电子表格：

' Fill this list with your desired values in the format: 
' "'Cell = Value" (Remove the existing lines) 

'C5 = "Hello" 
'D6 = "World" 
'E2 = 23.45 

---

交易破坏者：

• 您必须能够通过编程访问VBA项目Developer > Code > Macro Security > Trust access to the VBA project object model;

• 工作簿必须解锁（编程这样做是只能够通过使用邪恶SendKeys来完成）。

特点：

• 基本功能齐全的错误捕获实现;

• 对于重复的单元格，使用第一个单元格，其余部分将被丢弃;

• 额外的空间在任何地方合理允许，但不是强制性的;

• 单元格允许行情;

• 行情是高度建议但不要求字符串值（字之间的空格可能会导致语法错误）;

• 引号允许围绕数字值。

配置：

• 的NewbieProof模块名称是多变的，但必须与当地l_NewbieProof不断进行配对;

• 该SuperNewieProofData子名是多变的没有任何影响;

• NewbieProof模块头是完全可移除的;

• 如果需要，编程添加Microsoft Visual Basic For Applications Extensibility 5.3引用，因为所有VBIDE对象访问都是早期绑定的。这可以根据您的要求进行更改。

---

注意：如果您想了解我的变量命名约定，它是基于RVBA。