Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsSource As Worksheet
Dim lastRowSource As Long
Dim i As Long
Dim nameToFind As String
Dim projectNames As String
Dim projectDataList As String
Dim validationList As String
Dim cell As Range
Dim found As Boolean
Dim projectCollection As Collection
Dim nameCollection As Collection
Dim projectDataCollection As Collection
Dim projectName As Variant
Dim name As Variant
Dim selectedProject As String
Dim password As String
Dim tbl As ListObject
Dim tblRange As Range
Dim rowNumber As Long
password = "1807170"
On Error GoTo ErrorHandler
Me.Unprotect password
Set wsSource = Worksheets("source")
Application.EnableEvents = False
Set tbl = Me.ListObjects("Table2")
Set tblRange = tbl.DataBodyRange
rowNumber = Target.Row
If Not Intersect(Target, Me.Range("D:D")) Is Nothing Or Not Intersect(Target, Me.Range("E:E")) Is Nothing Then
If Target.Cells.Count > 1 Then GoTo CleanExit
If Target.Column = 4 Then
If Target.Value = "" Then
On Error Resume Next
Target.Validation.Delete
Target.Offset(0, 1).Validation.Delete
Target.Offset(0, 1).ClearContents
Target.Offset(0, 3).Validation.Delete
Target.Offset(0, 3).ClearContents
Me.Range("B" & rowNumber).ClearContents
Me.Range("C" & rowNumber).ClearContents
Me.Range("E" & rowNumber).ClearContents
Me.Range("G" & rowNumber).ClearContents
Me.Range("H" & rowNumber).ClearContents
Me.Range("j" & rowNumber).ClearContents
Me.Range("k" & rowNumber).ClearContents
On Error GoTo 0
GoTo CleanExit
End If
End If
If Target.Column = 4 And Target.Value <> "" Then
nameToFind = Target.Value
lastRowSource = wsSource.Cells(wsSource.Rows.Count, "J").End(xlUp).Row
Set nameCollection = New Collection
On Error Resume Next
For Each cell In wsSource.Range("J1:J" & lastRowSource)
If InStr(1, cell.Value, nameToFind, vbTextCompare) > 0 Then
nameCollection.Add cell.Value, CStr(cell.Value)
End If
Next cell
On Error GoTo 0
If nameCollection.Count > 0 Then
For Each name In nameCollection
validationList = validationList & name & ","
Next name
validationList = Left(validationList, Len(validationList) - 1)
Else
validationList = ""
End If
On Error Resume Next
With Target.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=validationList
.IgnoreBlank = True
.InCellDropdown = True
.ShowInput = True
.ShowError = True
End With
On Error GoTo 0
Target.Select
Application.SendKeys "%{DOWN}"
End If
If Target.Column = 4 And Target.Value <> "" Then
nameToFind = Target.Value
lastRowSource = wsSource.Cells(wsSource.Rows.Count, "J").End(xlUp).Row
Set projectCollection = New Collection
projectNames = ""
found = False
On Error Resume Next
For i = 2 To lastRowSource
If wsSource.Cells(i, "J").Value = nameToFind Then
projectCollection.Add wsSource.Cells(i, "L").Value, CStr(wsSource.Cells(i, "L").Value)
found = True
End If
Next i
On Error GoTo 0
If found Then
For Each projectName In projectCollection
projectNames = projectNames & projectName & ","
Next projectName
If Len(projectNames) > 0 Then
projectNames = Left(projectNames, Len(projectNames) - 1)
End If
On Error Resume Next
With Target.Offset(0, 1).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=projectNames
.IgnoreBlank = True
.InCellDropdown = True
.ShowInput = True
.ShowError = True
End With
On Error GoTo 0
Target.Offset(0, 1).Select
Application.SendKeys "%{DOWN}"
Else
Target.Offset(0, 1).ClearContents
Target.Offset(0, 1).Validation.Delete
End If
End If
If Target.Column = 5 And Target.Value <> "" Then
selectedProject = Target.Value
lastRowSource = wsSource.Cells(wsSource.Rows.Count, "J").End(xlUp).Row
Set projectDataCollection = New Collection
projectDataList = ""
found = False
On Error Resume Next
For i = 2 To lastRowSource
If wsSource.Cells(i, "l").Value = selectedProject And wsSource.Cells(i, "J").Value = Me.Cells(Target.Row, "D").Value Then
projectDataCollection.Add wsSource.Cells(i, "C").Value, CStr(wsSource.Cells(i, "C").Value)
found = True
End If
Next i
On Error GoTo 0
If found Then
For Each projectData In projectDataCollection
projectDataList = projectDataList & projectData & ","
Next projectData
If Len(projectDataList) > 0 Then
projectDataList = Left(projectDataList, Len(projectDataList) - 1)
End If
On Error Resume Next
With Me.Cells(Target.Row, "H").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=projectDataList
.IgnoreBlank = True
.InCellDropdown = True
.ShowInput = True
.ShowError = True
End With
On Error GoTo 0
Me.Cells(Target.Row, "H").Select
Application.SendKeys "%{DOWN}"
Else
Me.Cells(Target.Row, "H").ClearContents
Me.Cells(Target.Row, "H").Validation.Delete
End If
End If
If Target.Column = 4 Or Target.Column = 5 Then
Dim contractor As String
Dim project As String
Dim gValues As String
Dim uniqueGValues As Collection
contractor = Me.Cells(Target.Row, "D").Value
project = Me.Cells(Target.Row, "E").Value
If contractor <> "" And project <> "" Then
Set uniqueGValues = New Collection
On Error Resume Next
For Each cell In tblRange.Columns(7).Cells
If cell.Offset(0, -3).Value = contractor And cell.Offset(0, -2).Value = project Then
If cell.Row >= 3 Then
uniqueGValues.Add cell.Value, CStr(cell.Value)
End If
End If
Next cell
On Error GoTo 0
If uniqueGValues.Count > 0 And Target.Row = 1 Then
For Each gValue In uniqueGValues
gValues = gValues & gValue & ","
Next gValue
gValues = Left(gValues, Len(gValues) - 1)
On Error Resume Next
With Me.Cells(Target.Row, "G").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=gValues
.IgnoreBlank = True
.InCellDropdown = True
.ShowInput = True
.ShowError = True
End With
On Error GoTo 0
Me.Cells(Target.Row, "G").Select
Application.SendKeys "%{DOWN}"
End If
End If
End If
End If
CleanExit:
Application.EnableEvents = True
Me.Protect password
Exit Sub
ErrorHandler:
MsgBox "An error occurred. Please check your code."
Resume CleanExit
End Sub