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

我正在写一个VBA脚本，我想要以下两个function（伪代码）：

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可以写入表中的某个地方（未使用的列）。 例如，如果单元格地址input范围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 

---

当您尝试访问字典中的密钥时

• 如果密钥不存在，则新对将被无声添加到字典中

• 否则它不会创build重复的密钥，但其值将被更新

Answer 3

在快速加载字典的方法是创build一个名为Dictionary的构造函数，就像Array一样。

然后，您可以加载字典与键/项目作为参数alignment：

 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

一种方法是在代码最上面声明一个常量。 这样，新手不太可能破坏代码。

您可以使用任何字符作为分隔符，除了第一个空格和任何可能出现在有效文本值中的字符。

我已经展示了几种提取单元值对的方法。 删除所有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, eg, ":" 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 

注意声明的特殊结构，以便input数据的每一行都是相同的。 这会导致两个副作用：

• 声明之后必须有注释或空白行;
• 第一个单元值项目将始终为空。

Answer 5

我想不出比只包含一个子单元的单个模块更简单，其中单元值对的input就像普通的variables赋值一样：

 '=============================================================================== ' 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 

---

交易断路器：

• 您必须通过Developer > Code > Macro Security > Trust access to the VBA project object model来启用对VBA项目的编程访问;

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

特征：

• 基本全function错误捕获实施;

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

• 额外的空间可以在任何地方合理地允许，但不是在任

• 行情是允许周围细胞;

• 强烈推荐使用引号，但不要求string的值（单词之间的空格可能导致语法错误）;

• 行情是允许在数值附近。

组态：

• NewbieProof模块的名字是可以改变的，但是必须和l_NewbieProof本地常量配对。

• SuperNewieProofData子名是可以改变的，没有任何影响;

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

• 所有VBIDE对象访问都是早期绑定的，如果需要，可以编程方式添加Microsoft Visual Basic For Applications Extensibility 5.3参考。 这可以改变，以适应您的要求。

---

注意：如果您对我的variables命名惯例感到好奇，它基于RVBA 。