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

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

1 个答案: