Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("A2:A500")) Is Nothing Then
Dim strList As String
Dim ValCount As Long
Dim cell As Range, rngValidation As Range, nxTarget As Range
Dim rngTitle1 As Range, rngTitle2 As Range, rngTitle3 As Range, rngEnd As Range
Dim rngListGrp1 As Range, rngListGrp2 As Range, rngListGrp3 As Range
Dim rngGrp1 As Range, rngGrp2 As Range, rngGrp3 As Range
Dim Cond As Boolean
Dim dGrp1 As Object, dGrp2 As Object, dGrp3 As Object
Dim ws2 As Worksheet
Application.ScreenUpdating = False
Set ws2 = ActiveWorkbook.Sheets("DLoptions")
Set rngListGrp1 = ws2.Range("A2", ws2.Cells(Rows.Count, "A").End(xlUp))
Set rngListGrp2 = ws2.Range("B2", ws2.Cells(Rows.Count, "B").End(xlUp))
Set rngListGrp3 = ws2.Range("C2", ws2.Cells(Rows.Count, "C").End(xlUp))
Set dGrp1 = CreateObject("Scripting.Dictionary")
Set dGrp2 = CreateObject("Scripting.Dictionary")
Set dGrp3 = CreateObject("Scripting.Dictionary")
Set rngValidation = Range("A1", Cells(Rows.Count, "A").End(xlUp))
Set rngTitle1 = rngValidation.Find(What:="ListGrp1", LookAt:=xlWhole)
Set rngTitle2 = rngValidation.Find(What:="ListGrp2", LookAt:=xlWhole)
Set rngTitle3 = rngValidation.Find(What:="ListGrp3", LookAt:=xlWhole)
Set rngEnd = rngValidation.Find(What:="EndList", LookAt:=xlWhole)
If Not rngTitle1 Is Nothing And Not rngTitle2 Is Nothing Then
Set rngGrp1 = rngTitle1.Offset(1).Resize(rngTitle2.Row - rngTitle1.Row - 1, 1)
End If
If Not rngTitle2 Is Nothing And Not rngTitle3 Is Nothing Then
Set rngGrp2 = rngTitle2.Offset(1).Resize(rngTitle3.Row - rngTitle2.Row - 1, 1)
End If
If Not rngTitle3 Is Nothing And Not rngEnd Is Nothing Then
Set rngGrp3 = rngTitle3.Offset(1).Resize(rngEnd.Row - rngTitle3.Row - 1, 1)
End If
Cond = Not HasValidation(Target) And Not HasValidation(Target.Offset(1))
strList = ""
If Not Intersect(Target, rngGrp1) Is Nothing Then
For Each cell In rngGrp1
If Not cell = "" Then dGrp1.Add cell.Value, cell.Value
Next
'Create List
For Each cell In rngListGrp1
If Not dGrp1.Exists(cell.Value) Then
strList = strList & "," & cell.Value
End If
Next
If strList = "" Then
MsgBox "All list item has been used"
Exit Sub
Else
If Cond Then Target.Offset(1).EntireRow.Insert
End If
'Create Validation List
With Target
.Validation.Delete
.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=strList
End With
End If
If Not Intersect(Target, rngGrp2) Is Nothing Then
For Each cell In rngGrp2
If Not cell = "" Then dGrp2.Add cell.Value, cell.Value
Next
'Create List
For Each cell In rngListGrp2
If Not dGrp2.Exists(cell.Value) Then
strList = strList & "," & cell.Value
End If
Next
If strList = "" Then
MsgBox "All list item has been used"
Exit Sub
Else
If Cond Then Target.Offset(1).EntireRow.Insert
End If
'Create Validation List
With Target
.Validation.Delete
.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=strList
End With
End If
If Not Intersect(Target, rngGrp3) Is Nothing Then
For Each cell In rngGrp3
If Not cell = "" Then dGrp3.Add cell.Value, cell.Value
If HasValidation(cell) Then ValCount = ValCount + 1
Next
'Create List
For Each cell In rngListGrp3
If Not dGrp3.Exists(cell.Value) Then
strList = strList & "," & cell.Value
End If
Next
If strList = "" Or ValCount = rngListGrp3.Count Then
MsgBox "All list item has been used"
Exit Sub
Else
If Cond Then Target.Offset(1).EntireRow.Insert
End If
'Create Validation List
With Target
.Validation.Delete
.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=strList
End With
End If
End If
Application.ScreenUpdating = True
End Sub
Function HasValidation(cell As Range) As Boolean
Dim valType As Long
HasValidation = True
On Error Resume Next
valType = cell.Validation.Type
If Err.Number <> 0 Then HasValidation = False
On Error GoTo 0
End Function
