Vba

C@thy

XLDnaute Barbatruc
Bonjour le forum:),

j'ai une macro qui fonctionnait super bien sous 2003, mais avec 1 million de lignes ça ne passe plus :
Code:
Sub SupprimerColonnes()
Dim c As Long, dercol As Long, Plg As Range, derlig As Long, réponse As Byte
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
derlig = Cells(1048576, 1).End(xlUp).Row 'rajouté por faire la modif
réponse = MsgBox("Attention vous allez supprimer des colonnes dont la date de fin est antérieure à 60 jours", vbOKCancel, 48)
If réponse = 1 Then
dercol = [XFD1].End(xlToLeft).Column 'modifié pour 2010
For c = 15 To dercol
    If Cells(2, c) < Date - 60 Then
        If Plg Is Nothing Then
            Set Plg = Columns(c)
        Else
             Set Plg = Union(Plg, Columns(c))
        End If
    End If
Next c
Plg.Select
If Not Plg Is Nothing Then Plg.Delete
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = True
End If
End Sub

et là, patatras, message "Excel ne peut terminer cette tâche avec les ressources disponibles sélectionnez moins de données ou fermez des applications"...
mais je n'ai qu'Excel d'ouvert...

il ne faut donc pas supprimer toutes les colonnes, mais juste la partie correspondant à la hauteur du tableau (dernière ligne rempli col. A) et décaler vers la gauche

Comment puis-je corriger proprement mon code???

Un très grand MERCI à ceux qui voudraient bien se pencher sur cette question.

Bises et bonne journée:cool:

C@thy
 
Dernière édition:

job75

XLDnaute Barbatruc
Re : Vba

Re,

Encore un point, pour le tri ceci est peut-être plus rapide :

Code:
Sub SupprimerColonnes()
If MsgBox("Attention vous allez supprimer des colonnes dont la date de fin est antérieure à 60 jours...", 49) = 2 Then Exit Sub
Dim derlig&
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
On Error Resume Next 's'il n'y a aucune colonne à supprimer
[1:1].Insert 'ligne auxiliaire
With Intersect([O1].Resize(, Columns.Count - 14), ActiveSheet.UsedRange.EntireColumn)
  derlig = .EntireColumn.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
  .FormulaR1C1 = "=LN(R3C>=TODAY()-60)"
  .Value = .Value 'suppression des formules
  .Resize(derlig).Sort Rows(1), xlAscending, Orientation:=xlLeftToRight 'tri
  Intersect(.SpecialCells(xlCellTypeConstants, 16).EntireColumn, Rows("1:" & derlig)).Delete xlToLeft
  .EntireColumn.AutoFit 'ajustement automatique
End With
[1:1].Delete 'suppression de la ligne auxiliaire
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
A+
 

C@thy

XLDnaute Barbatruc
Re : Vba

Coucou, Gérard,

juste encore une petite chose (j'y ai pensé cette nuit!)
pour le plus grand bonheur de mes utilisateur, comme nous n'arrivons pas non plus à supprimer une colonne à la main, je vais faire une boite de dialogue qui donnera le choix (boutons radio) entre :
supprimer les colonnes
1-dont la date d'arrivée est antérieure à 60 jours
2- sélectionnées

par conséquent il faudrait également pouvoir, à partir de la sélection, ne décaler vers la gauche que la plage correspondant à ces colonnes, si tu vois ce que je veux dire... donc, une deuxième macro un peu dans le même style mais qui ne tiendrait pas compte des dates de fin en haut.
Donc pas besoin de tri, si il y a plusieurs colonnes sélectionnées elles seront contigües.
Puis-je encore abuser de ta gentillesse?

En te remerciant grandement.

Bises et bonne journée, ainsi qu'à Marie-Anna.


C@thy
 
Dernière édition:

job75

XLDnaute Barbatruc
Re : Vba

Bonjour C@thy,

Je crains que tu n'aies pas compris à quoi sert le tri horizontal.

Son seul but est d'accélérer la suppression des dates en les groupant en fin de tableau à droite.

Il est facultatif, tu peux tester en mettant son code en commentaire.

Quant à ton nouveau problème essaie cette macro :

Code:
Sub SupprimerColonnes()
Dim rep As Byte, derlig&
rep = MsgBox("Cliquez sur Oui pour supprimer uniquement les colonnes sélectionnées." _
      & vbLf & "Cliquez sur Non pour supprimer toutes les colonnes.", 51, _
      "Dates de fin antérieures à 60 jours")
If rep = 2 Then Exit Sub 'bouton Annuler
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
On Error Resume Next 's'il n'y a aucune colonne à supprimer
[1:1].Insert 'ligne auxiliaire
With Intersect([O1].Resize(, Columns.Count - 14), ActiveSheet.UsedRange.EntireColumn)
  derlig = .EntireColumn.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
  If rep = 6 Then .Value = 0
  IIf(rep = 6, Intersect(Selection.EntireColumn, .Cells), .Cells) _
    .FormulaR1C1 = "=LN(R3C>=TODAY()-60)"
  .Value = .Value 'suppression des formules
  .Resize(derlig).Sort Rows(1), xlAscending, Orientation:=xlLeftToRight 'tri
  Intersect(.SpecialCells(xlCellTypeConstants, 16).EntireColumn, Rows("1:" & derlig)).Delete xlToLeft
  .EntireColumn.AutoFit 'ajustement automatique
End With
[1:1].Delete 'suppression de la ligne auxiliaire
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
A+
 

job75

XLDnaute Barbatruc
Re : Vba

Re,

Maintenant si tu veux supprimer les colonnes sélectionnées quelles que soient leurs dates il vaut mieux une seconde macro :

Code:
Sub SupprimerColonnesSelectionnées()
Dim derlig&
If MsgBox("Toutes les colonnes sélectionnées à partir de la colonne O seront supprimées.", 49) = 2 Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
On Error Resume Next 's'il n'y a aucune colonne à supprimer
[1:1].Insert 'ligne auxiliaire
With Intersect([O1].Resize(, Columns.Count - 14), ActiveSheet.UsedRange.EntireColumn)
  derlig = .EntireColumn.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
  .Value = 0
  Intersect(Selection.EntireColumn, .Cells) = "a"
  .Resize(derlig).Sort Rows(1), xlAscending, Orientation:=xlLeftToRight 'tri
  Intersect(.SpecialCells(xlCellTypeConstants, 2).EntireColumn, Rows("1:" & derlig)).Delete xlToLeft
  .EntireColumn.AutoFit 'ajustement automatique
End With
[1:1].Delete 'suppression de la ligne auxiliaire
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
A+
 

job75

XLDnaute Barbatruc
Re : Vba

Re,

Une autre solution qui donne le même résultat :

Code:
Sub SupprimerColonnesSelectionnées()
Dim derlig&
If MsgBox("Toutes les colonnes sélectionnées à partir de la colonne O seront supprimées.", 49) = 2 Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
On Error Resume Next 's'il n'y a aucune colonne à supprimer
[1:1].Insert 'ligne auxiliaire
With Intersect([O1].Resize(, Columns.Count - 14), ActiveSheet.UsedRange.EntireColumn)
  derlig = .EntireColumn.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
  .Value = 0
  Intersect(Selection.EntireColumn, .Cells).ClearContents 'cellules vides
  .Resize(derlig).Sort Rows(1), Orientation:=xlLeftToRight 'tri
  Intersect(.SpecialCells(xlCellTypeBlanks).EntireColumn, Rows("1:" & derlig)).Delete xlToLeft
  .EntireColumn.AutoFit 'ajustement automatique
End With
[1:1].Delete 'suppression de la ligne auxiliaire
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Quel que soit l'ordre du tri les cellules vides se retrouvent à la fin.

A+
 

C@thy

XLDnaute Barbatruc
Re : Vba

Coucou,

alors voilà, j'ai testé, c'est parfait,
j'ai fait un userform avec 2 boutons radio pour supprimer
1- les col date fin < 60j
2- les col. sélectionnées

il manque juste un message lorsque
- dans le 1er cas il n'y a pas de date < à 60 jours
- dans le 2ème cas on a sélectionné une mauvaise colonne (avant la col O)
et pis à la fin pour dire qu'il l'a fait... (suppression effectuée).

Un grand MERCI, Gérard

Bises et bonne jounée

C@thy
 
Dernière édition:

job75

XLDnaute Barbatruc
Re : Vba

Bonjour C@thy,

il manque juste un message (...)

Une solution bien simple, tu places au début des 2 macros :

Code:
Dim ncol%, derlig&
ncol = [O1].CurrentRegion.Columns.Count
et à la fin des macros :

Code:
If [O1].CurrentRegion.Columns.Count < ncol Then
  MsgBox ncol - [O1].CurrentRegion.Columns.Count & " colonne(s) supprimée(s)..."
Else
  MsgBox "Aucune date de fin antérieure à 60 jours..." 'supprimer la ligne inutile
  MsgBox "Aucune colonne sélectionnée à partir de la colonne O..."
End If
Pour la 2ème MsgBox n'oublie pas de supprimer la ligne inutile.

Edit : [O1].CurrentRegion est préférable à ActiveSheet.UsedRange...

A+
 
Dernière édition:

Discussions similaires

Réponses
7
Affichages
384
Réponses
28
Affichages
1 K

Membres actuellement en ligne

Statistiques des forums

Discussions
312 836
Messages
2 092 652
Membres
105 479
dernier inscrit
chaussadas.renaud