如果不在范围内,则将 Excel 2016 用户窗体文本框的值传递到命名范围
Pass value from Excel 2016 userform textbox to a named range if not already in range
我有一个 Excel 2016 用户窗体,其中包含一个文本框和命令按钮。我希望能够在文本框中键入一个或多个名称,并让用户窗体在检查重复项后将它们添加到命名范围。如果该名称已经在命名范围内,我希望将该名称添加到我的 MsgAdd 字符串并继续到文本框的下一行(如果适用)。
***新尝试:
这是我第一次尝试使用字典。当我尝试使用 .Add 而不是 .Item 时,我收到一条关于已存在值的错误消息。字典在宏的开头应该是空的?我的命名范围被循环并添加。然后 dict.exist 应该触发,如果该值存在,它应该添加到我的消息字符串中,如果不存在,它应该添加到命名范围的底部。但是,该值现在添加到 "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 造成的,但我似乎无法找到解决方法。如果有人有一些意见,我们将不胜感激。
对于从事类似工作的任何其他人。在添加字典并解决其他一些问题后完全 运行。
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 用户窗体,其中包含一个文本框和命令按钮。我希望能够在文本框中键入一个或多个名称,并让用户窗体在检查重复项后将它们添加到命名范围。如果该名称已经在命名范围内,我希望将该名称添加到我的 MsgAdd 字符串并继续到文本框的下一行(如果适用)。
***新尝试: 这是我第一次尝试使用字典。当我尝试使用 .Add 而不是 .Item 时,我收到一条关于已存在值的错误消息。字典在宏的开头应该是空的?我的命名范围被循环并添加。然后 dict.exist 应该触发,如果该值存在,它应该添加到我的消息字符串中,如果不存在,它应该添加到命名范围的底部。但是,该值现在添加到 "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 造成的,但我似乎无法找到解决方法。如果有人有一些意见,我们将不胜感激。
对于从事类似工作的任何其他人。在添加字典并解决其他一些问题后完全 运行。
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