Supprimer des lignes suivant un critère

Sub test()
Dim Plage As Range
With Sheets("Feuil1").Range("A1:A15000")
    Set c = .Find("PARIS", LookIn:=xlValues, LookAt:=xlWhole)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
            If Not Plage Is Nothing Then
                Set Plage = Union(Plage, Range(c, c.Offset(0, 2)))
            Else
                Set Plage = Range(c, c.Offset(0, 2))
            End If
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
End With
Plage.Copy Sheets("Feuil2").Range("A1")
End Sub

Sub Test2()
Dim Cellule1 As Range, Cellule2 As Range
If Range("A1") = "PARIS" Then
Set Cellule1 = Range("A1")
Else
Set Cellule1 = Range("A1:A15000").Find(What:="PARIS", After:=Range("A1"), LookIn:=xlValues, LookAt:= _
    xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
    , SearchFormat:=False)
End If
Set Cellule2 = Range("A1:A15000").Find(What:="PARIS", After:=Range("A1"), LookIn:=xlValues, LookAt:= _
    xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
    , SearchFormat:=False)
Range(Cellule1, Cellule2).Copy Sheets("Feuil2").Range("A1")
End Sub

Sub test()
Dim dossier As Object, fichier As Object
Dim i&, j&, m&, s$, dDat(), oDat, dat(), g&
Dim Rep$
Application.ScreenUpdating = False
dDat = Array(Array("PARIS", dat), Array("LYON", dat))
Rep = ThisWorkbook.Path & "\"
Set dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Rep & "/")
For Each fichier In dossier.Files
    If Right(fichier.Name, 3) = "xls" And fichier.Name <> ThisWorkbook.Name Then
        Workbooks.Open Filename:=fichier
        With ActiveWorkbook.Sheets("Feuil1")
            For i = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
              s = UCase(CStr(.Cells(i, 1).Value))
              For j = 0 To UBound(dDat)
                If dDat(j)(0) = s Then
                  oDat = dDat(j)(1)
                  m = 0
                  On Error Resume Next
                  m = 1 + UBound(oDat, 2)
                  On Error GoTo 0
                  ReDim Preserve oDat(0 To 2, 0 To m)
                  oDat(0, m) = Cells(i, 1): oDat(1, m) = Cells(i, 2): oDat(2, m) = Cells(i, 3)
                  dDat(j)(1) = oDat
                End If
              Next
            Next
        End With
        ActiveWorkbook.Close False
    End If
Next fichier
On Error Resume Next
For j = 0 To UBound(dDat)
  oDat = dDat(j)(1)
  With Sheets(dDat(j)(0)).[A1]
    .CurrentRegion.ClearContents
    .Resize(UBound(oDat, 2) + 1, UBound(oDat, 1) + 1).Value = WorksheetFunction.Transpose(oDat)
  End With
Next
On Error GoTo 0
Application.ScreenUpdating = True
End Sub