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

我将与那些从未在其生活中编写过脚本的同事分享这一点（但他们能够使用像vlookup这样的Excel公式等）。因此，我需要能够非常简单地将单元格编号和相应的值写在彼此旁边。

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

如果1 0 0和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

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

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

如果密钥不存在，新对将以静默方式添加到字典中
否则它不会创建重复键，但会更新其值

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

执行此操作的一种方法是在代码的最顶部声明一个常量。这样，新手不太可能破坏代码。

您可以为任一分隔符使用任何字符，第一个 Space 除外，可能出现在有效文本中的任何字符除外两个值。

我已经展示了一些提取单元格值对的方法。删除除1之外的所有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

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

必须是宣言后的评论或空白行;
第一个单元格值项将始终为空。

Answer 5

我想不出比仅包含一个模块的单个模块更简单的东西 sub，其中输入的Cell-Value对就像普通的变量赋值一样：

'===============================================================================
' 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完成）。

功能

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

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

在任何地方都可以合理地允许使用额外的空格，但在任何地方都不是必须的;

细胞周围允许引用;

引用高度推荐但不需要围绕字符串值（单词之间的空格可能会导致语法错误）;

数字值允许引号。

<强>配置：

NewbieProof模块名称可更改，但必须与l_NewbieProof本地常量配对;

SuperNewieProofData子名称可以更改而不会产生任何影响;

NewbieProof模块标题可以完全删除;

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

注意：如果您对我的变量命名约定感到好奇，那么它基于RVBA。

输入密钥＆lt;＆gt;的简单方法是什么？ VBA中的值对？

5 个答案: