XL 2016 rechercher un mot dans une base

Sub test()
    Dim addr$, mot$, oldmot$, i&, c As Range, firstAddress$, punion As Range, cel As Range
    With Worksheets("Base")
        Set plage = .Range("b2:b" & .Cells(Rows.Count, "b").End(xlUp).Row)
        oldmot = .Cells(2, 1).Text
        .Cells(Rows.Count, 1).End(xlUp).Offset(1) = "xxxx" 'obligé d'ajouter sinon il prend pas la derniere va savoir pourquoi
        For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
            If .Cells(i, "A").Text <> "" Then
                mot = .Cells(i, "A").Text
                If mot <> oldmot Then
                    If Not punion Is Nothing Then
                        If Not punion.Cells(1) Like "*" & oldmot & "*" Then Set punion = Range(Replace(punion.Address, punion.Cells(1).Address & ",", ""))
                        'nextrow = Sheets("résultat").Cells(Rows.Count, 2).End(xlUp).Offset(3).Row
                        'Sheets("résultat").Cells(nextrow, 1) = oldmot

                        'For Each area In punion.Areas
                            'For Each cel In area.Cells
                                'nextrow = Sheets("résultat").Cells(Rows.Count, 2).End(xlUp).Offset(1).Row
                                'Sheets("résultat").Cells(nextrow, 2) = cel.Text
                            'Next
                        'Next
                        Debug.Print oldmot & " : " & punion.Address: oldmot = mot: Set punion = Nothing
                    End If
                End If
                Set c = plage.Find(mot, Lookat:=xlPart)
                If Not c Is Nothing Then
                    firstAddress = c.Address
                    Do
                        If punion Is Nothing Then Set punion = c Else Set punion = Union(punion, c)
                        addr = addr & c.Address & " "
                        Set c = plage.FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> firstAddress
                End If
            End If
        Next
        .Cells(Rows.Count, 1).End(xlUp) = ""
    End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$2" Then
    Nbre = 0
    Application.ScreenUpdating = False
    Cells.Font.Color = vbBlack
    fin = Sheets(2).[B65000].End(xlUp).Row + 1
    ligne = fin
    mot = Target
    For Each c In [b2:b10000]
      p = 1: témoin = False
      Do While p > 0
        p = InStr(p, c, mot)
        If p > 0 Then
          ligne = ligne + 1
          c.Characters(p, Len(mot)).Font.ColorIndex = 3: Nbre = Nbre + 1
          c.Characters(p, Len(mot)).Font.Bold = True
          p = p + Len(mot)
          témoin = True
        End If
      Loop
      If témoin Then lig = c.Row: Rows(lig).Copy Sheets(2).Cells(ligne, 1)
    Next c
    '[A3] = p & " " & " ( " & Nbre & " )"

    [A3] = Range("A2").Value & "  - " & Nbre
    Range("A3").Characters(InStr(1, Range("A3").Value, Nbre), Len(Nbre)).Font.Name = "Calibri"
    Range("A3").Characters(InStr(1, Range("A3").Value, Nbre), Len(Nbre)).Font.Size = 11
  End If
End Sub

Sub trans()
    Dim temoins As Boolean, mot$, p&
    With Sheets("base ")
        mot = .[A2].Text
        MsgBox mot
        For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
            p = InStr(1, .Cells(i, 2).Value, mot)
            If p > 1 Then Debug.Print Cells(i, 2).Address(0, 0) & " position " & p
        Next
    End With
End Sub