) :Sub Demo1()
With Sheet1
.UsedRange.Columns(6).ClearContents
VA = .Cells(1).CurrentRegion.Columns(1).Value
VD = .Range("D1", .Cells(.Rows.Count, 4).End(xlUp)).Value
For R& = 1 To UBound(VD)
SP = Split(VD(R, 1), "\")
For N& = 0 To UBound(SP)
If IsError(Application.Match(SP(N), VA, 0)) Then SP(N) = False
Next
VD(R, 1) = Join(Filter(SP, False, False), "\")
Next
.Cells(6).Resize(UBound(VD)).Value = VD
End With
End SubSub Demo1a()
Const FR = 4
With Sheet1
Range(.Cells(FR - 1, 6), .Cells(.Rows.Count, 6).End(xlUp)).Offset(1).Clear
VA = Range(.Cells(FR, 1), .Cells(FR - 1, 1).End(xlDown)).Value
VD = Range(.Cells(FR, 4), .Cells(.Rows.Count, 4).End(xlUp)).Value
For R& = 1 To UBound(VD)
SP = Split(VD(R, 1), "\")
For N& = 0 To UBound(SP)
If IsError(Application.Match(SP(N), VA, 0)) Then SP(N) = False
Next
VD(R, 1) = Join(Filter(SP, False, False), "\")
Next
.Cells(FR, 6).Resize(UBound(VD)).Value = VD
End With
End SubOption Explicit
Sub test()
Dim a, i As Long, myPtn As String, m, temp As String
myPtn = Join(Filter([transpose(if(a1:a1000<>"",a1:a1000,char(2)))], Chr(2), 0), Chr(2))
With Range("d1", Range("d" & Rows.Count).End(xlUp))
a = .Value
With CreateObject("VBScript.RegExp")
.Global = True: .IgnoreCase = True
.Pattern = "([$()\-^|\\{}\[\]*+?.])"
myPtn = Replace(.Replace(myPtn, "\$1"), Chr(2), "|")
.Pattern = "\b(" & myPtn & ")\b"
For i = 2 To UBound(a, 1)
For Each m In .Execute(a(i, 1))
temp = temp & "\" & m.Value
Next
a(i, 1) = ""
If Len(temp) Then a(i, 1) = Mid$(temp, 2): temp = ""
Next
End With
.Offset(, 2).Value = a
End With
End Sub