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"
' Unprotect the sheet
On Error GoTo ErrorHandler
Me.Unprotect password
' Set the source worksheet
Set wsSource = Worksheets("source")
Application.EnableEvents = False
' Set the table and its range
Set tbl = Me.ListObjects("Table2")
Set tblRange = tbl.DataBodyRange
' Get the row number of the changed cell
rowNumber = Target.Row
' Check if the change is in column D or E
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 ' Exit if multiple cells are changed
' Clear validation and contents for E and G if D is cleared
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 ' Clear E
Target.Offset(0, 3).Validation.Delete
Target.Offset(0, 3).ClearContents ' Clear G
Me.Range("B" & rowNumber).ClearContents ' Clear B
Me.Range("C" & rowNumber).ClearContents ' Clear C
Me.Range("E" & rowNumber).ClearContents ' Clear E
Me.Range("G" & rowNumber).ClearContents ' Clear G
Me.Range("H" & rowNumber).ClearContents ' Clear H
Me.Range("j" & rowNumber).ClearContents ' Clear j
Me.Range("k" & rowNumber).ClearContents ' Clear k
On Error GoTo 0
GoTo CleanExit
End If
End If
' Update validation for D dynamically as you type
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
' Find matching names
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
' Create validation list
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
' Apply validation to D
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
' Show the dropdown list for column D
Target.Select
Application.SendKeys "%{DOWN}"
End If
' Update validation for E based on D
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 ' Start from row 2
If wsSource.Cells(i, "J").Value = nameToFind Then ' Column J should match the name
projectCollection.Add wsSource.Cells(i, "L").Value, CStr(wsSource.Cells(i, "L").Value)
found = True
End If
Next i
On Error GoTo 0
' Create validation list for E
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
' Apply validation to E
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
' Show the dropdown list for column E
Target.Offset(0, 1).Select
Application.SendKeys "%{DOWN}"
Else
Target.Offset(0, 1).ClearContents
Target.Offset(0, 1).Validation.Delete
End If
End If
' Update validation for E
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 ' Start from row 2
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
' Create validation list for H
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
' Apply validation to H
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
' Show the dropdown list for column H
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
' Update validation for G
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 ' Column G
If cell.Offset(0, -3).Value = contractor And cell.Offset(0, -2).Value = project Then
' Skip adding validation for G3 and below
If cell.Row >= 3 Then
uniqueGValues.Add cell.Value, CStr(cell.Value)
End If
End If
Next cell
On Error GoTo 0
' Create validation list for G1
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)
' Apply validation to G1
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
' Show the dropdown list for column G
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
