如果尚未在范围内，则将值从 Excel 2016 用户窗体文本框传递到命名范围

Question

我有一个包含文本框和命令按钮的 Excel 2016 用户表单。我希望能够在文本框中键入一个或多个名称，并让用户窗体在检查重复项后将它们添加到命名范围。如果名称已经在命名范围内，我希望将该名称添加到我的 MsgAdd 字符串并继续到文本框的下一行（如果应用）。

***新尝试： 这是我第一次尝试使用字典。当我尝试使用 .Add 而不是 .Item 时，我收到一条错误消息，说明该值已存在。字典在宏开始时应该是空的？我的命名范围循环并添加。然后 dict.exist 应该触发，如果值存在，它应该添加到我的 msg 字符串中，如果不存在，它应该添加到命名范围的底部。但是，该值现在添加到“A2”，而不是在范围的末尾，如果文本框中有不止一行，则覆盖自身。

Private Sub AddAnalyst()
' Select Tools->References from the Visual Basic menu.
' Check box beside "Microsoft Scripting Runtime" in the list.
Dim ws          As Worksheet
Dim i           As Long
Dim FreeRow     As String
Dim TBLines()   As String
Dim MsgAdd      As String
Dim xFound      As Integer
Dim Cell        As Range
Dim Rng         As Range
Dim dict        As Object

Set Rng = Range("Name")

'Build Dictionary
Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare  'Capitalization does not apply

    For Each Cell In Rng.Cells 'Loop through range & add to dictionary
        dict.Item(Cell.Value) = Cell.Address(RowAbsolute:=False, ColumnAbsolute:=False)
    Next Cell

    TBLines = Split(Add_Analyst_Form.AddAnalystTB.Text, vbCrLf)

    For i = LBound(TBLines) To UBound(TBLines)

        If dict.Exists(i) Then 'Add to message string for end msgbox
            xFound = xFound + 1
            MsgAdd = MsgAdd & vbCrLf & UBound(TBLines, i)
        Else
            With ws
                FreeRow = WorksheetFunction.CountA(Range("A:A")) + 1
                Sheets("Lists").Range("A" & FreeRow) = TBLines(i)
            End With
        End If
    Next i

If xFound <> 0 Then MsgBox ("Analyst(s)," & MsgAdd & ", is/are already entered into the database and will not be added.") 'msg name already exists

Set dict = Nothing   
End Sub

以前尝试过（在字典之前）：

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''   
Private Sub AddAnalyst()
Dim ws             As Worksheet
Dim i              As Long
Dim FreeRow        As String
Dim TBLines()      As String
Dim MsgAdd         As String
Dim sFind          As String
Dim rFound         As Range
Dim valueFound     As Integer

TBLines = Split(Add_Analyst_Form.AddAnalystTB.Text, vbCrLf) 

For i = LBound(TBLines) To UBound(TBLines) 'Cycle through all lines of the textbox

    On Error Resume Next 'Skip error that will occur if rFound does not exist.
    sFind = UBound(TBLines, i)
    Set rFound = Sheets("Lists").Range("Name").Find(sFind, LookIn:=xlValues, LookAt:=xlWhole)

    If Not rFound Is Nothing Then 'Add value to string for later MsgBox & increase integer
        valueFound = valueFound + 1
        MsgAdd = MsgAdd & vbCrLf & UBound(TBLines, i)
        GoTo NextIteration
    Else
        With ws 'Name is not duplicated in range, add to range.
            FreeRow = WorksheetFunction.CountA(Range("A:A")) + 1
            Sheets("Lists").Range("A" & FreeRow) = TBLines(i)
        End With
    End If
NextIteration:
Next i

'Msgbox will be displayed if 1 or more of the values previously existed.
If valueFound <> 0 Then MsgBox ("Analyst(s)," & MsgAdd & ", is/are already entered into the database and will not be added.") 'msg name already exists

End Sub

我的脚本似乎没有检查重复项。它只是自动添加到我命名范围的底部。我认为这是由于我的 On Error Resume 但我似乎无法找到解决方法。如果有人有一些意见，将不胜感激。

Answer 1

对于其他从事类似工作的人。添加字典并解决其他一些问题后完全运行。

Private Sub AddAnalyst()
' Select Tools->References from the Visual Basic menu.
' Check box beside "Microsoft Scripting Runtime" in the list.
Dim ws          As Worksheet
Dim i           As Integer
Dim FreeRow     As String
Dim TBLines()   As String
Dim MsgAdded    As String
Dim MsgExist    As String
Dim xFound      As Integer
Dim yFound      As Integer
Dim Cell        As Range
Dim dict        As Scripting.Dictionary

'Build Dictionary
Set dict = New Scripting.Dictionary
    dict.CompareMode = vbTextCompare  'Capitalization does not apply to dictionary

    For Each Cell In Range("Name").Cells 'Add named range to dictionary
        With Cell
            dict(Cell.Value) = Cell.Address(RowAbsolute:=False, ColumnAbsolute:=False)
        End With
    Next Cell

    TBLines = Split(Add_Analyst_Form.AddAnalystTB.Text, vbCrLf) 'Split string when there are multiple lines

    For i = LBound(TBLines) To UBound(TBLines) 'Loop through split string
        If dict.Exists(TBLines(i)) Then
            xFound = xFound + 1
            MsgExist = MsgExist & vbCrLf & TBLines(i)
        Else
            With Sheets("Lists")
                FreeRow = .Range("A" & Rows.Count).End(xlUp).Row + 1 'First free row in Column A of Reasoning&Lists sheet
                .Range("A" & FreeRow) = TBLines(i)
            End With
            yFound = yFound + 1
            MsgAdded = MsgAdded & vbCrLf & TBLines(i)
        End If
    Next i
Set dict = Nothing

Unload Add_Analyst_Form 'Close out userform

If xFound <> 0 And yFound <> 0 Then
    MsgBox ("Analyst(s):" & MsgExist & vbCrLf & "already exists in the database and will not be added." & vbCrLf & vbCrLf & "Analyst(s):" & MsgAdded & vbCrLf & "have been added to the database.")
ElseIf xFound <> 0 And yFound = 0 Then
    MsgBox ("Analyst(s):" & MsgExist & vbCrLf & "already exists in the database and will not be added.") 'msg name already exists
ElseIf xFound = 0 And yFound <> 0 Then
    MsgBox ("Analyst(s):" & MsgAdded & vbCrLf & "have been added to the database.") 'msg name was added to database
End If

End Sub