how can i copy/paste the word which is found during search in the current row wise

this code working but can i paste which word was found in the Row to its opposite Row

i my excel in column F

i have list of words which is to be serached and paste the which word found in the row(colored yellow)

IT IS POSSIBLE TO DO LIKE THIS

example like:

if i found the word CABLE in the row

D E

ELECTRICAL,CABLE, EXTENSION, 12V, 5 METER | CABLE
BELT, V, 376IN OC, 0.65625IN WD, 0.40625IN THK | BELT

Sub FindAndColor()

    Dim cell        As Variant
    Dim FndWhat     As String
    Dim RegExp      As Object
    Dim RngBeg      As Range
    Dim RngEnd      As Range
    Dim SearchWords As Variant
    Dim Word        As Variant
    
    
        Set RngBeg = Range("F2")
        Set RngEnd = Cells(Rows.Count, "F").End(xlUp)
        If RngEnd.Row < RngBeg.Row Then Exit Sub
        
        SearchWords = Range(RngBeg, RngEnd).Value
        
        Set RngBeg = Range("D2")
        Set RngEnd = Cells(Rows.Count, "D").End(xlUp)
        If RngEnd.Row < RngBeg.Row Then Exit Sub
        
        
        Set RegExp = CreateObject("VBScript.RegExp")
        RegExp.IgnoreCase = True
        
        Application.ScreenUpdating = False
        
            For Each Word In SearchWords
                RegExp.Pattern = "\b" & Word & "\b"
                For Each cell In Range(RngBeg, RngEnd)
                    If RegExp.Execute(cell).Count > 0 Then
                        cell.Interior.ColorIndex = 6
                        cell.Interior.Pattern = xlSolid
                    End If
                Next cell
            Next Word
        
        Application.ScreenUpdating = True
        
End Sub

i have added some line of code after this line If RngEnd.Row < RngBeg.Row Then Exit Sub

adding some line it is copying entire column of D

but i am trying to display only which full word was found in D reference to the F Column

should be displayed Only search words in E Column

i have attached file

Sub FindAndColor()

    Dim cell        As Variant
    Dim FndWhat     As String
    Dim RegExp      As Object
    Dim RngBeg      As Range
    Dim RngEnd      As Range
    Dim SearchWords As Variant
    Dim Word        As Variant
    
    
        Set RngBeg = Range("F2")
        Set RngEnd = Cells(Rows.Count, "F").End(xlUp)
        If RngEnd.Row < RngBeg.Row Then Exit Sub
        
        SearchWords = Range(RngBeg, RngEnd).Value
        
        Set RngBeg = Range("D2")
        Set RngEnd = Cells(Rows.Count, "D").End(xlUp)
        If RngEnd.Row < RngBeg.Row Then Exit Sub
        
         With Range("D2:D800")
'         .AutoFilter Field:=7, Criteria1:="=*Line*"
        Intersect(Range("D2:D" & Rows.Count), .SpecialCells(xlCellTypeVisible).EntireRow).Copy _
        Sheets("Sheet1").Range("E" & Rows.Count).End(xlUp).Offset(1, 0)
        End With
        'Selection.AutoFilter
        
        Set RegExp = CreateObject("VBScript.RegExp")
        RegExp.IgnoreCase = True
        
        Application.ScreenUpdating = False
        
            For Each Word In SearchWords
                RegExp.Pattern = "\b" & Word & "\b"
                For Each cell In Range(RngBeg, RngEnd)
                    If RegExp.Execute(cell).Count > 0 Then
                        cell.Interior.ColorIndex = 6
                        cell.Interior.Pattern = xlSolid
                    End If
                Next cell
            Next Word
        
        Application.ScreenUpdating = True
        
End Sub