Hi Stackoverflow community,
Below is a list of sites and a list of customers in Column A and Column B of "Sheet 1" in Excel respectively.
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.
Below is my VBA code:
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 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 ;)
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.