Macro suppression lignes vides

Le 24/10/2011 à 13:20

Bonjour,

je souhaiterais mettre en place une macro qui à l'enregistrement ou à la fermeture du fichier supprime toutes les lignes qui ont une cellule vide en A. La suppression de la ligne et du quadrillage car cela m'alourdit les fichiers.

En fait, j'ai une 100aine d'équipe et un fichier par semaine. Pour chaque fichier préparé à l'avance j'ai 500 lignes mais en fonction des semaines et des équipes je n'utilise parfois qu'une 50aine de lignes.

Dans le fichier j'ai plusieurs macros mais toutes ne fonctionnent pas correctement sur la pièce jointe car j'ai supprimé des feuilles n'ayant pas de rapport avec ma demande.

Mon fichier est également protégé par un mot de passe qui est "motdepasse".

Pour finir l'explication, toutes les données de la colonne A à la colonne J sont copiées chaque semaine sur ce fichier car extraite d'un logiciel sous un format TXT.

Je créé donc tous les fichiers pour toutes les équipes pour chaque semaine grâce à une macro du fichier et toutes sous le même format (fichier institutionnalisé).

Merci de bien vouloir m'aider à corriger ma macro de suppression de lignes qui ne fonctionne pas bien sans que j'arrive à trouver l'erreur (actuellement elle est en application avant l'enregistrement) et le code est :

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim lig As Long
With Sheets("Séjours à coder")
If .Range("A3") = "" Then Exit Sub
    lig = .Cells(Rows.Count, 1).End(xlUp).Row
    .Range(.Cells(lig + 1, 1), .Cells(lig + 1, 23).End(xlDown)).Delete Shift:=xlUp
    On Error Resume Next
    With .Range("A4:A" & lig).SpecialCells(xlCellTypeBlanks).EntireRow
        .Delete Shift:=xlUp
    End With
End With
End Sub
27classeur1.zip (60.20 Ko)
Le 24/10/2011 à 13:45

Bonjour

Modifies cette procédure

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

Dim lig As Long
With Sheets("Séjours à coder")
If .Range("A3") = "" Then Exit Sub
  Application.EnableEvents = False
  .Unprotect Password:="motdepasse"
    lig = .Cells(Rows.Count, 1).End(xlUp).Row
    .Range(.Cells(lig + 1, 1), .Cells(lig + 1, 23).End(xlDown)).Delete Shift:=xlUp
    On Error Resume Next
    With .Range("A4:A" & lig).SpecialCells(xlCellTypeBlanks).EntireRow
        .Delete Shift:=xlUp
    End With
    .Protect Password:="motdepasse", DrawingObjects:=True, Contents:=True, Scenarios:=True, _
    AllowSorting:=True, AllowInsertingRows:=True, AllowDeletingRows:=True, AllowFiltering:=True
  Application.EnableEvents = True

End With
End Sub
Le 24/10/2011 à 15:22

je te remercie, ça à l'air de fonctionner impec...

Une autre question en rapport avec ce fichier : certains collègues qui n'ont aucune formation en excel (d'où les mots de passe pour protéger) ne font pas la mise en page demandée (quadrillage sur les premières cellules).

Pour moi c'est inutile mais les chefs ont décidé qu'il devait y être.

Comment mettre en place une macro pour que si la cellule en A est remplie (à partir de A3) alors le quadrillage est fait comme sur le fichier joint. Cette macro peut être combinée à la précédente. Si A vide, suppression du quadrillage, si A non vide mise en place du quadrillage de A à J.

Encore merci

Le 24/10/2011 à 16:51

Bonjour

Modifies la macro

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim lig As Long
  With Sheets("Séjours à coder")
  If .Range("A3") = "" Then Exit Sub
    Application.EnableEvents = False
    .Unprotect Password:="motdepasse"
      lig = .Cells(Rows.Count, 1).End(xlUp).Row
      .Range(.Cells(lig + 1, 1), .Cells(lig + 1, 23).End(xlDown)).Delete Shift:=xlUp
      On Error Resume Next
      With .Range("A4:A" & lig).SpecialCells(xlCellTypeBlanks).EntireRow
          .Delete Shift:=xlUp
      End With
      .Range("A3:W" & .Range("A" & Rows.Count).End(xlUp).Row).Borders.Weight = xlThin
      .Protect Password:="motdepasse", DrawingObjects:=True, Contents:=True, Scenarios:=True, _
      AllowSorting:=True, AllowInsertingRows:=True, AllowDeletingRows:=True, AllowFiltering:=True
    Application.EnableEvents = True
  End With
End Sub
Le 24/10/2011 à 17:10

merci c'est super, mais je voudrais juste entre J et K un trait épais, ainsi qu'entre A2 et A3

Encore merci pour ton aide

Le 24/10/2011 à 17:47

Bonjour

Je t'ai fait aussi le trait épais sur les autres colonnes comme dans l'original

Macro à remplacer

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim lig As Long
  With Sheets("Séjours à coder")
  If .Range("A3") = "" Then Exit Sub
    Application.EnableEvents = False
    .Unprotect Password:="motdepasse"
      lig = .Cells(Rows.Count, 1).End(xlUp).Row
      .Range(.Cells(lig + 1, 1), .Cells(lig + 1, 23).End(xlDown)).Delete Shift:=xlUp
      On Error Resume Next
      With .Range("A4:A" & lig).SpecialCells(xlCellTypeBlanks).EntireRow
          .Delete Shift:=xlUp
      End With
      On Error GoTo 0
      lig = .Range("A" & Rows.Count).End(xlUp).Row
      .Range("A3:W" & lig).Borders.Weight = xlThin
      .Range("A3:W3").Borders(xlEdgeTop).Weight = xlThick
      .Range("J3:J" & lig & ",N3:N" & lig & ",N3:N" & lig & ",S3:S" & lig & ",V3:V" & lig & ",W3:W" & lig).Borders(xlEdgeRight).Weight = xlThick
      .Protect Password:="motdepasse", DrawingObjects:=True, Contents:=True, Scenarios:=True, _
      AllowSorting:=True, AllowInsertingRows:=True, AllowDeletingRows:=True, AllowFiltering:=True
    Application.EnableEvents = True
  End With
End Sub
Le 24/10/2011 à 18:21

encore merci pour ton aide.

J'ai un message d'erreur dans la macro :

"Erreur d'exécution '1004' :

impossible définir la propriété Weight de la classe Borders"

.Range("A3:W" & lig).Borders.Weight = xlThin

Est-ce que le fait d'être sous 2010 peut être la cause de cette erreur?

Le 24/10/2011 à 18:36

Bonjour

matt31 a écrit :

.Range("A3:W" & lig).Borders.Weight = xlThin

Je viens d'essayer (avec 2003) pas de soucis

C'est la même chose que dans la macro précédente

.Range("A3:W" & .Range("A" & Rows.Count).End(xlUp).Row).Borders.Weight = xlThin

J'ai juste remplacer la définition .Range("A" & Rows.Count).End(xlUp).Row par Lig qui est égal à lig = .Range("A" & Rows.Count).End(xlUp).Row

Pourquoi cela fonctionne dans un sens et pas dans l'autre ?

Vérifies bien ton code

Si la macro est planté il y a de fortes chances que les évènements ne soient plus interceptés

il faut lancer manuellement une macro du style

Sub Ret
Application.EnableEvents = True
End Sub
Le 24/10/2011 à 19:10

j'ai testé sur un autre fichier, tout fonctionne normalement et correctement.

Où mets-tu cette macro ?

Sub Ret
Application.EnableEvents = True
End Sub

Workbook, feuille ou module?

la macro plante à la 2° ouverture du fichier.

La 1° fois elle trace correctement les lignes. La 2° fois par contre, que je la mette avant l'enregistrement ou avant la fermeture, elle plante à l'endroit indiqué.

Le 24/10/2011 à 21:10

Bonsoir

Pour la macro ret peu importe l'endroit

C'est une macro à lancer manuellement au cas ou tu t'aperçois que il n'y a plus d'interception des d'évènements (suite à un plantage de la macro )

Pour le plantage je ne sais point

Je viens , d'ouvrir, de sauvegarder et fermer, plusieurs fois de suite et pas de plantage

Essayes de remplacer la ligne incriminée par celle-ci

Je n'y crois pas mais bon on teste

.Range("A3:W" & .Range("A" & Rows.Count).End(xlUp).Row).Borders.Weight = xlThin
Le 24/10/2011 à 21:52

C'est exactement la même chose.

la macro fonctionne la 1° fois et ensuite à la 2° fois j'ai le même message d'erreur.

Je confirme par contre que sous 2003 il n'y a pas de problème.

Le 24/10/2011 à 22:17

Bonsoir

Moi je n'ai que 2003

Si quelqu'un veut bien tester sous 2007 afin de trouver l'incompatibilité et le remède , d'avance merci

Rechercher des sujets similaires à "macro suppression lignes vides"