Supprimer une ligne si une cellule sur trois est vides

Bonjour,

Je souhaite créer une macro mais je me suis un peu perdu.

J'ai un tableau qui regroupe une base de donnée client, je souhaite supprimer un client qui n'a renseigné aucun moyen de contact. Sachant que les trois moyens de contact sont : Tel mobile / Tel fixe / mail

Je voudrais faire en sorte que lorsque qu'il n'y a aucun moyen de communication renseigné dans les colonne H - I et J la ligne entière comportant le client soit supprimé. Mais pas quand celle-ci comporte au moins un moyen de contact sur les trois, dans ce cas précis alors la ligne n'est pas supprimée.

Merci d'avance ! :D

Hello,

un petit fichier stp :)

Hello,

Et voila ! :D

Hello, essaie en copiant ça dans un module

Sub SupprLignes()

Dim wS As Excel.Worksheet

Set wS = ThisWorkbook.Sheets(1)

With wS

    For L = 2 To .Cells(Rows.Count, 1).End(xlUp).Row

        If .Range("H" & L).Value = "" And .Range("I" & L).Value = "" And .Range("J" & L).Value = "" Then
        .Range(L & ":" & L).EntireRow.Delete shift:=xlUp
        L = L - 1
        End If

    Next L

End With

End Sub

Ca marche nickel merci ! Ya t'il un moyen de rendre la durée du traitement moins longue ? Car j'ai environ 5000 lignes :D

Pour être plus précis cela fait 20 min que Excel plante, je pense que le programme tourne tout le temps.

Ah oui désolé tu aurais dû préciser le nb de lignes! Tu peux interrompre le traitement en maintenant la touche ESC appuyée et ajouter une instruction application.screenupdating = false au début et application.screenupdating = true à la fin (juste avant end sub)

Après c'est aussi possible de laisser tourner jusqu'à la fin, si ton PC est un peu lent c'est surement normal

D'accord, merci je n'ai pas vraiment de nombre de ligne précis car l'extraction que je fais peut varier au fil du temps, merci de ton temps !

Hello à tous

Tu peux également rajouter l'instruction suivante

Application.Calculation = xlCalculationManual comme suit :

Sub blabla()

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

'
'
' Ton code
'
'

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End sub

@+

Bonjour à tous,

Un essai ....

Sub test()
 Dim tb, k%, i%, col%

  Application.ScreenUpdating = False

   With Sheets("Feuil1")
    tb = .Range("A1").CurrentRegion
    k = 0

    ReDim Newtb(0 To UBound(tb, 1), 1 To 10)
     For i = 1 To UBound(tb, 1)
       If tb(i, 8) <> "" And tb(i, 9) <> "" And tb(i, 10) <> "" Then
        For col = 1 To 10
         Newtb(k, col) = tb(i, col)
        Next col
        k = k + 1
       End If
     Next i

     If k > 0 Then
     .Range("A1").CurrentRegion.ClearContents
     .Range("A1").Resize(k, 10).Value = Newtb
    End If
  End With
 Erase tb
End Sub

Cordialement,

Bonjour le fil,

Mème idée que Xorsankukai que je salue

Comme j'ai fait mon code, je le donne quand même

Sub SupprLignes()
  Dim dLig As Long, Ind As Long, IndD As Long
  Dim TabLigS As Variant, TabLigD() As String
  Dim Col As Long
  With ThisWorkbook.Sheets(1)
    ' dernière ligne remplie de la feuille
    dLig = .Range("A" & Rows.Count).End(xlUp).Row
    ' Mettre la plage dans un tableau
    TabLigS = .Range("A2:J" & dLig)
    ' Traiter ce tableau
    For Ind = 1 To UBound(TabLigS)
      ' Si l'indice 8, 9 ou 10 n'est pas vide
      If TabLigS(Ind, 8) <> "" Or TabLigS(Ind, 9) <> "" Or TabLigS(Ind, 10) <> "" Then
        ' On incrémente l'Indice de Destination
        IndD = IndD + 1
        ' On redimensionne en gardant les valeurs
        ReDim Preserve TabLigD(10, IndD)
        ' Pour chaque colonne
        For Col = 0 To 9
          ' on les insère dans le tableau
          TabLigD(Col, IndD) = TabLigS(Ind, 1 + Col)
        Next Col
      End If
    Next Ind
    ' Effacer les données existantes
    .Range("A2:J" & dLig).ClearContents
    ' Réinjecter le tableau
    .Range("A2").Resize(IndD + 1, 11).Value = Application.Transpose(TabLigD)
  End With
End Sub

A+

Bonjour, problème résolu merci beaucoup !