您可以拆分列D中的值，并检查是否有任何单个值匹配。

Private Sub txtreg_Change()

    Dim lookupValue As String: lookupValue = txtreg.value
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws As Worksheet: Set ws = wb.Sheets("L 403")
    
    txtledglist.Clear
    
    Dim rng As Range: Set rng = ws.Range("A:A,D:D")  ' Update the range to include columns A and D
    On Error Resume Next
    Dim firstCell As Range: Set firstCell = rng.Find(What:=lookupValue, LookIn:=xlValues, LookAt:=xlWhole)
    On Error GoTo 0
    
    If Not firstCell Is Nothing Then
        Dim cell As Range: Set cell = firstCell
        Dim results() As Variant
        Dim count As Long: count = 0
        
        Do
            count = count + 1
            Set cell = rng.FindNext(cell)
        Loop While Not cell Is Nothing And cell.Address <> firstCell.Address
        
        ReDim results(1 To count, 1 To 1)
        
        Set cell = rng.Find(What:=lookupValue, LookIn:=xlValues, LookAt:=xlWhole)
        
        Dim index As Long: index = 1
        Do
            Dim values() As String
            values = Split(ws.Cells(cell.Row, "D").Value, ",") ' Split the values in column D by comma
            
            ' Iterate through each split value and check if it matches the lookupValue
            For Each value In values
                If Trim(value) = lookupValue Then
                    results(index, 1) = ws.Cells(cell.Row, "B").value & "  " & ws.Cells(cell.Row, "C").value
                    index = index + 1
                    Exit For ' Exit the loop if a match is found
                End If
            Next value
            
            Set cell = rng.FindNext(cell)
        Loop While Not cell Is Nothing And cell.Address <> firstCell.Address

        txtledglist.List = results

    End If
End Sub