Enlever automatiquement des lignes

Bonjour a tous

J'ai un petit probleme avec ma base de donnée qui contient 200000 personnes, J'aimerai insérer une commande qui enlèvera automatiquement les lignes dont j'ai pas besoin

en fait j'aimerai que ca enleve automatiquement les lignes dont les colonne A et B ne contiennent pas le chiffre 35' je veux dire que au moins une des deux colonnes contient le chiffre 35 ou bien les deux, dans les autres cas ou le chiffre 35 n'est pas present faudrait qu'il l'enleve automatiquement

merci pour votre aide

Bonsoir,

Proposition à tester et à adapter suivant tes besoins.

Cdlt

Option Explicit
Public Sub SupprimeNon35()
Dim sh_1 As Worksheet, sh_2 As Worksheet
Dim Plage As Range
Dim TbBase
Dim nbLignes As Long, nbColonnes As Byte
Dim i As Long, j As Byte, x As Long
Dim TbRésultat()
Dim CellDest As Range
'------------------------------------------------------------------------------
    With Application
        .Calculation = False
        .ScreenUpdating = False
    End With
'------------------------------------------------------------------------------
    Set sh_1 = Worksheets("Base de données brutes")
    Set sh_2 = Worksheets("Base épurée")
    sh_1.Activate

    With sh_1
        Set Plage = Range("A1").CurrentRegion
        TbBase = Plage.Value
        nbLignes = UBound(TbBase, 1)
        nbColonnes = UBound(TbBase, 2)
        x = 0
        j = 1
        For i = nbLignes To 1 Step -1
            If TbBase(i, j) = 35 Or TbBase(i, j + 1) = 35 Then
                x = x + 1: ReDim Preserve TbRésultat(1 To 2, 1 To x)
                TbRésultat(1, UBound(TbRésultat, 2)) = TbBase(i, 1)
                TbRésultat(2, UBound(TbRésultat, 2)) = TbBase(i, j + 1)
            End If
        Next i
    End With
'------------------------------------------------------------------------------
    With sh_2
        Set CellDest = .Range("A1")
        CellDest.Range("A1:B" & x).Value = Application.Transpose(TbRésultat)
    End With
'------------------------------------------------------------------------------
    With Application
        .Calculation = True
        .ScreenUpdating = True
    End With

    Set sh_1 = Nothing: Set sh_2 = Nothing
    Set Plage = Nothing: Set CellDest = Nothing

End Sub
Rechercher des sujets similaires à "enlever automatiquement lignes"