Recherche données pour copier sur une autre feuille

Bonjour à tous,

Je débute en VBA et j'aurai besoin de réaliser cette opération pourtant basique pour un projet:

Il faut qu'a partir d'une fenêtre de dialogue l'interlocuteur entre le nom de la commune recherchée pour qu'Excel la recherche dans "BDD", copie toute la ligne correspondante + la ligne 2 (en-têtes) et aille coller ces informations sur une autre feuille.

Pour finir, il devra supprimer cette feuille nouvellement créer lorsque l'interlocuteur retournera sur la feuille "BDD"

Merci d'avance

Bonjour

J'ai juste retouché ton propre code

Rassure-toi de ne pas ajouter une feuille utile nommée Feuil3 ou bien, change Feuil3 en un nouveau nom comme sur ce code

Sub Nouveau()
Dim rngTrouve As Range
Dim strChaine As String, firstAddress As String
Dim N As Long, i As Byte
    N = 2
    strChaine = InputBox("Commune souhaitée")
    If strChaine = "" Or IsNumeric(strChaine) Or IsDate(strChaine) Then Exit Sub
    Set rngTrouve = Sheets("BDD").Columns(4).Cells.Find(strChaine, , xlValues, xlWhole)
    If Not rngTrouve Is Nothing Then
        firstAddress = rngTrouve.Address
    On Error Resume Next
        Do
           For i = 1 To Sheets.Count
               If Sheets(i).Name = "NewName" Then Sheets(i).Activate: GoTo Here
           'Exit For
           Next i
            ActiveWorkbook.Sheets.Add(after:=Sheets(Sheets.Count)).Name = "NewName"
Here:
            Sheets("BDD").Range("A2:G2").Copy Sheets("NewName").Range("A1")
            rngTrouve.EntireRow.Copy Sheets("NewName").Range("A" & N)
            N = N + 1
            Set rngTrouve = Sheets("BDD").Columns(4).FindNext(rngTrouve)
        Loop While Not rngTrouve Is Nothing And rngTrouve.Address <> firstAddress
    Else
        MsgBox "Pas trouvé"
    End If
End Sub

Et si tu renommes, n'oublie pas de modifier aussi le code dans la Feuille BDD en remplaçant Feuil3 par le nouveau nom

Private Sub Worksheet_Activate()
Dim i As Byte
Application.DisplayAlerts = False
On Error Resume Next
For i = 1 To Sheets.Count
    If Sheets(i).Name = "NewName" Then
        Sheets(i).Delete
    End If
Next i
Application.DisplayAlerts = True
End Sub

A plus

C'est parfait merci beaucoup