Я пишу сценарий 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
}

Возможно ли что-то подобное?

4
Stewie Griffin 2 Сен 2017 в 14:03

4 ответа

Лучший ответ

Я не могу придумать ничего более простого, чем отдельный модуль, содержащий ровно одну подпрограмму, где пары 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

Для успешного использования этого саба требуется немного магии через сам объект IDE VBA. Подумайте, как можно изменить код. В этом случае код только читает подпрограмму из модуля NewbieProof, извлекая пары Cell-Value.

Эта магия заключена в вспомогательную функцию 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.

1
robinCTS 8 Сен 2017 в 09:01

Вы также можете получить всю информацию с листа, включая адреса ячеек

Если у вас есть на листе 1:

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

Когда вы пытаетесь получить доступ к ключу в словаре

  • Если ключ не существует, новая пара будет автоматически добавлена в словарь

  • В противном случае он не создаст дубликат ключа, но его значение будет обновлено.

2
paul bica 2 Сен 2017 в 13:20

Чтобы быстро загрузить словарь, можно создать конструктор с именем 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
2
Florent B. 2 Сен 2017 в 17:22

Я думаю, это можно упростить, если 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
2
Mrig 2 Сен 2017 в 12:14