[英]Variable Data Validation with multiple lists
Hi Stackoverflow community, 您好Stackoverflow社区,
Below is a list of sites and a list of customers in Column A and Column B of "Sheet 1" in Excel respectively. 下面是Excel中“表格1”的A列和B列中的网站列表和客户列表。
Site Customer
Paddington A
Sydney B
Vaucluse A
Maroubra A
Woollahra B
Sydney A
Sydney A
The issues that I am experiencing is as follows: 我遇到的问题如下:
My data validation list of sites are unique (no duplicates). 我的网站数据验证列表是唯一的(无重复)。 However, I also need my Customers to be unique in nature as well.
但是,我也需要我的客户在本质上也要独特。 Example of issue: "Sydney" is unique in the site list but Customer is B,A,A in the Customer List when "Sydney" is selected.
问题示例:“悉尼”在站点列表中是唯一的,但是当选择“悉尼”时,客户在客户列表中是B,A,A。
Below is my VBA code: 以下是我的VBA代码:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, LastRow As Long, n As Long
Dim MyCol As Collection
Dim SearchString As String, TempList As String
Application.EnableEvents = False
On Error GoTo Whoa
'~~> Find LastRow in Col A
LastRow = Range("A" & Rows.Count).End(xlUp).Row
If Not Intersect(Target, Columns(1)) Is Nothing Then
Set MyCol = New Collection
'~~> Get the data from Col A into a collection
For i = 2 To LastRow
If Len(Trim(Range("A" & i).Value)) <> 0 Then
On Error Resume Next
MyCol.Add CStr(Range("A" & i).Value), CStr(Range("A" & i).Value)
On Error GoTo 0
End If
Next i
'~~> Create a list for the DV List
For n = 1 To MyCol.Count
TempList = TempList & "," & MyCol(n)
Next
TempList = Mid(TempList, 2)
Range("D1").ClearContents: Range("D1").Validation.Delete
'~~> Create the DV List
If Len(Trim(TempList)) <> 0 Then
With Range("D1").Validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=TempList
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End If
'~~> Capturing change in cell D1
ElseIf Not Intersect(Target, Range("D1")) Is Nothing Then
SearchString = Range("D1").Value
TempList = FindRange(Range("A2:A" & LastRow), SearchString)
Range("E1").ClearContents: Range("E1").Validation.Delete
If Len(Trim(TempList)) <> 0 Then
'~~> Create the DV List
With Range("E1").Validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=TempList
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End If
End If
LetsContinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
'~~> Function required to find the list from Col B
Function FindRange(FirstRange As Range, StrSearch As String) As String
Dim aCell As Range, bCell As Range, oRange As Range
Dim ExitLoop As Boolean
Dim strTemp As String
Set aCell = FirstRange.Find(what:=StrSearch, LookIn:=xlValues, _
lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
ExitLoop = False
If Not aCell Is Nothing Then
Set bCell = aCell
strTemp = strTemp & "," & aCell.Offset(, 1).Value
Do While ExitLoop = False
Set aCell = FirstRange.FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
strTemp = strTemp & "," & aCell.Offset(, 1).Value
Else
ExitLoop = True
End If
Loop
FindRange = Mid(strTemp, 2)
End If
End Function
Any assistance would kindly be appreciated 任何帮助将不胜感激
Thanks in advance 提前致谢
If you don't care about losing the duplicate rows, your program will get all unique values for both if you add the line: 如果您不关心丢失重复的行,那么如果添加以下行,则程序将获得两个行的所有唯一值:
Range("A:B").RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
At the top - after the On Error
and before the LastRow calc 在顶部-在出现
On Error
和LastRow计算之前
On Error GoTo Whoa
'~~> Find LastRow in Col A
LastRow = Range("A" & Rows.Count).End(xlUp).Row
By skipping some parts for your code, it should do as you want it to: 通过跳过代码的某些部分,它应按您希望的方式执行:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim vals As Variant, MyCol As New Collection, runner As Variant, str As String, i As Long
If Not Intersect(Target, Columns(1)) Is Nothing Then
vals = Range("A2", Cells(Rows.Count, 1).End(xlUp)).Value2
Range("D1").ClearContents
On Error Resume Next
For Each runner In vals
If Len(Trim(runner)) Then
MyCol.Add Trim(runner), Trim(runner)
End If
Next
On Error GoTo 0
If MyCol.Count Then
For Each runner In MyCol
str = str & "," & runner
Next
With Range("D1").Validation
.Delete
.Add 3, 1, 1, Mid(str, 2)
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End If
ElseIf Not Intersect(Target, Range("D1")) Is Nothing Then
vals = Range("B2", Cells(Rows.Count, 1).End(xlUp)).Value2
runner = Range("D1").Value2
Range("E1").ClearContents
On Error Resume Next
For i = 1 To UBound(vals)
If Trim(vals(i, 1)) = runner Then
MyCol.Add Trim(vals(i, 2)), Trim(vals(i, 2))
End If
Next
On Error GoTo 0
If MyCol.Count Then
For Each runner In MyCol
str = str & "," & runner
Next
With Range("E1").Validation
.Delete
.Add 3, 1, 1, Mid(str, 2)
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End If
End If
End Sub
Tested it with the data you provided -> acted with desired behavior. 使用您提供的数据对其进行了测试->行为符合预期。
EDIT 编辑
For also sorting, I suggest rewriting the sub a bit to keep it small (while some stuff will not be that obvious) 对于排序,我建议稍微重写一下子以使其较小(尽管有些东西不会那么明显)
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim vals As Variant, runner As Variant
Dim MyCol As New Collection
Dim str As String, str2 As String
Dim i As Long
Dim tp As Boolean
If Not Intersect(Target, Union(Columns(1), Range("D1"))) Is Nothing Then
Application.EnableEvents = False
tp = Not Intersect(Target, Columns(1)) Is Nothing
vals = Range("B2", Cells(Rows.Count, 1).End(xlUp)).Value2
Range(Array("E1", "D1:E1")(-tp)).ClearContents
runner = IIf(tp, " ", Range("D1").Value2)
On Error Resume Next
For i = 1 To UBound(vals)
If (Trim(vals(i, 1)) = runner) Or (Len(Trim(vals(i, 1))) > 0 And tp) Then
MyCol.Add Trim(vals(i, 2 + tp)), Trim(vals(i, 2 + tp))
End If
Next
On Error GoTo 0
If MyCol.Count Then
While MyCol.Count
str2 = ""
For Each runner In MyCol
If Len(str2) Then
If StrComp(str2, runner) = 1 Then str2 = runner
Else
str2 = runner
End If
Next
str = str & "," & str2
MyCol.Remove str2
Wend
With Range(Array("E1", "D1")(-tp)).Validation
.Delete
.Add 3, 1, 1, Mid(str, 2)
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End If
Application.EnableEvents = True
End If
End Sub
If you have any questions, just ask ;) 如果你有问题,就问吧 ;)
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.