Supprimer plusieurs cellules automatiquement

[goodsayan]

Bonjour
Je souhaite supprimer automatiquement des cellules d'une colonne suivant leurs positions.
Mon tableau est comme ca:
cellules 1 a 6 à supprimer
cellules 7 à 10 a garder
cellules 11 à 14 à supprimer
cellules 15 à 20 à suppimer
cellules 21 à 24 a garder
cellules 25 à 28 à supprimer
Etc...
Et cela sur toutes une colonne de taille variable.

Mon probleme peut donc se décomposer en 2:
suppression des 1 à 6, puis 15 à 20 etc... il y a 5 lignes à supprimer
suppression des 11 à 14, puis 25 à 28 etc... il y a 3 lignes à supprimer

Si quelqu'un connait une macro pouvant faire au moins un des sous problemes? Après je devrais pouvoir l'adapter pour l'autre partie.
Merci

 

[Spitnolan08]

Re : Supprimer plusieurs cellules automatiquement

Bonsoir le fil,

Fred65200, tu as raison pour Excel2007 avec la formule figée de matthieu33 mais avec cette formulation ouverte ça fonctionne dans tous les cas:

Sub test()
DerLig = Range("A" & Application.Rows.Count).End(xlUp).Row
DerCol = Cells(1, Application.Columns.Count).End(xlToLeft).Column
End Sub

Et puis tout le monde n'a pas encore 2007

Bonne soirée
Cordialement

 

[goodsayan]

Re : Supprimer plusieurs cellules automatiquement

voici la solution qui correspond parfaitement a ce que j'attendais.

Private Sub SupLigne()
    Dim lgLig As Long
    Dim bTrouve As Boolean
    Dim lgDerLig As Long
    Dim lgDerCol As Long
        
    Application.ScreenUpdating = False
    
    ' Trouver la dernière cellule de la feuille
    ActiveCell.SpecialCells(xlLastCell).Select
    ' Dernière ligne
    lgDerLig = ActiveCell.Row
    ' Dernière colonne contenant le plus grand nombre de lignes
    lgDerCol = Cells(lgDerLig, Cells.Columns.Count).End(xlToLeft).Column
    
    
    ' Remplacer le point par une virgule pour avoir un format numérique
'    Cells.Select
'    Selection.Replace What:=".", Replacement:=",", LookAt:=xlPart, _
'        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
'        ReplaceFormat:=False
    
    Range("A1").Select
    
    bTrouve = False
    
    ' Boucle de la dernière à la première ligne
    For lgLig = lgDerLig - 1 To 1 Step -1
        ' Si la valeur de la cellule n'est pas numérique ou vide, on la supprime
        If Not IsNumeric(Cells(lgLig, lgDerCol).Value) Or Cells(lgLig, lgDerCol).Value = "" Then
            Cells(lgLig, lgDerCol).Select
            Selection.EntireRow.Delete
            
            bTrouve = True
        End If
    Next lgLig

    ' Sauvegarder le classeur pour permettre la récupération de la dernière ligne
    ActiveWorkbook.Save
    
    ' Trouver la dernière cellule de la feuille
    ActiveCell.SpecialCells(xlLastCell).Select
    ' Dernière ligne
    lgDerLig = ActiveCell.Row
    ' Dernière colonne contenant le plus grand nombre de lignes
    lgDerCol = Cells(lgDerLig, Cells.Columns.Count).End(xlToLeft).Column
    
    ' Suppression uniquement si des lignes numériques ont été supprimées
    If bTrouve = True Then
        ' Boucle de la dernière à la première ligne
        For lgLig = lgDerLig To 1 Step -5
            Cells(lgLig, lgDerCol).Select
            Selection.EntireRow.ClearContents
        Next lgLig
    End If

    Application.ScreenUpdating = True
End Sub

Private Sub cmdSupLigne_Click()
    Call SupLigne
End Sub

Un grand merci à Matthieu33 et aussi à Fred65200