How to copy data to new tab depending in word in a second tab

Please HELP!!!

The program below is looking at the Field "Organisation" in the "Data" tab and copies any data that matches the exact contents on Column A in the "Buss Type" Tab into a new Tab called "Target-Data"

Could you show me how to change it so that it copies into the "Target-Data" Tab any data that contains the word listed in Column A in the "Buss Type" Tab any where in the content of the Field "Organisation" in the "Data" Tab?

Option Explicit

Sub Buss_Select()
    Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet, ws5 As Worksheet, ws6 As Worksheet
    Dim Rng As Range, cel As Range
    Dim ToTRow As Long, LR As Long, LR1 As Long, x As Long
    Dim Headers As Variant
    Dim awf As WorksheetFunction: Set awf = WorksheetFunction
    Dim lColumn As Long
    Dim vColumn As Long
    Dim uColumn
    Dim tColumn As String

    lColumn = awf.Match("Organisation", Rows(1), 0)

    vColumn = Cells(1, Columns.Count).End(xlToLeft).Column
    uColumn = Split(Cells(1, vColumn).Address, "$")

    tColumn = uColumn(LBound(uColumn) + 1)

    Set ws = Sheets("Buss Type")
    Set ws1 = Sheets("Data")
    With ws1
        Headers = WorksheetFunction.Transpose(.Range("A1", .Range("A1").End(xlToRight)).Value)
    End With
    
    Application.ScreenUpdating = False
    If Not Evaluate("ISREF('Target-Data'!A1)") Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Target-Data"
        Sheets("Target-Data").Range("A1").Resize(1, UBound(Headers)).Value = WorksheetFunction.Transpose(Headers)
    Else
        Sheets("Target-Data").UsedRange.Offset(1, 0).ClearContents
    End If
    Set ws2 = Sheets("Target-Data")

    With ws
        ToTRow = .Columns("A").Find(what:="End", LookIn:=xlValues, lookat:=xlWhole).Row - 1

        Set Rng = .Range("A2:A" & ToTRow)
        For Each cel In Rng
            With ws1
                LR = .Cells.Find("*", .Cells(Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious).Row
                .Range("A1:" & tColumn & LR).AutoFilter Field:=lColumn, Criteria1:=cel.Value
                Set Rng = .AutoFilter.Range
                x = Rng.Columns(lColumn).SpecialCells(xlCellTypeVisible).Count - 1
                If x >= 1 Then
                Rng.Offset(1, 0).Copy
                    With ws2
                        LR1 = .Cells.Find("*", .Cells(Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                                SearchDirection:=xlPrevious).Row + 1
                        .Range("A" & LR1).PasteSpecial
                    End With
                End If
            End With
        Next cel
        ws1.AutoFilterMode = False
    End With
    ws2.Columns.AutoFit
    Application.ScreenUpdating = True
End Sub