XL 2010 VBA Macro pour supprimer une colonne sur deux

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

jlbcall

XLDnaute Occasionnel
Bonsoir à tous,

Je souhaiterais faire une macro pour supprimer à partir de la colonne C une colonne sur deux.
Ces colonnes sont vides et pollue donc un fichier qui vient d'une interface.
Exemple: Garder les colonnes A B D F mais supprimer ensuite les vides C-E-G-I-K-M....
Ci-joint un fichier

Merci d'avance bonne soirée
 

Pièces jointes

Bonsoir jlbcall,

Cette macro supprime toutes les colonnes vides, un point c'est tout :
Code:
Sub SupprimerColonnesVides()
Dim c As Range, Sup As Range
For Each c In ActiveSheet.UsedRange.Columns
    If Application.CountA(c) = 0 Then Set Sup = Union(IIf(Sup Is Nothing, c, Sup), c)
Next
If Not Sup Is Nothing Then Sup.EntireColumn.Delete
End Sub
A+
 
Bonjour Jlbcall, Job75

@job75
Cette solution synthétique(#2) est excellente mais je préfère toujours partir d'un code qui travaille sur les cellules non vides donc avec un autre de tes codes.
Le code ci-joint supprime les lignes / colonnes mais me parait un peu long dans sa rédaction (pas forcément dans son efficacité, même si je n'ai pas testé sur de longues plages).
Si tu as des précisions pour le simplifier , je suis preneur de tes recommandations, comme toujours et t'en remercie par avance

Bonne journée
zebanx

VB:
Sub sh05_supp_RC_vides()
Dim plage1 As Range, plage2 As Range
Dim dercol%, derligne%, r2cd$, r2cf$

dercol = Cells(1, Columns.Count).End(1).Column
derligne = Cells(Rows.Count, 1).End(3).Row
Set plage1 = Range(Cells(derligne, 1), Cells(derligne, dercol))

On Error Resume Next
'--- supprimer colonnes
With plage1.Offset(1, 0)
  .Formula = "=1/(1/SUMPRODUCT(N(A2:A" & derligne - 1 & "<>"""")))"
  .Value = .Value
  .SpecialCells(xlCellTypeConstants, 16).EntireColumn.Delete
  .Value = ""
End With

dercol = Cells(1, Columns.Count).End(1).Column
Set plage2 = Range(Cells(2, dercol), Cells(derligne, dercol))
r2cd = Cells(2, 1).Address(0, 0)
r2cf = Cells(2, dercol).Address(0, 0)

'--- supprimer lignes
With plage2.Offset(0, 1)
  '.Formula = "=1/(1/SUMPRODUCT(N(A2:" & r2cf & "<>"""")))"
  .Formula = "=1/(1/SUMPRODUCT(N(" & r2cd & ":" & r2cf & "<>"""")))"
  .Value = .Value
  .SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete
  .Value = ""
End With
With ActiveSheet.UsedRange: End With '---actualise les barres de défilement
End Sub
 

Pièces jointes

Dernière édition:
Bonjour zebanx,

Oui s'il y a beaucoup (plusieurs milliers) de lignes ou de colonnes disjointes à supprimer la fonction Union pédale dans la choucroute.

On pourra alors essayer cette macro :
Code:
Sub SupprimerLignesColonnes()
Application.ScreenUpdating = False
On Error Resume Next 'si aucune SpecialCell
With ActiveSheet 'à adapter
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    '---suppression des lignes vides---
    With .UsedRange.Columns(.UsedRange.Columns.Count + 1)
        .FormulaR1C1 = "=1/COUNTA(RC1:RC[-1])"
        .Value = .Value
        .SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete
        .ClearContents
    End With
    '---suppression des colonnes vides---
    With .UsedRange.Rows(.UsedRange.Rows.Count + 1)
        .FormulaR1C1 = "=1/COUNTA(R1C:R[-1]C)"
        .Value = .Value
        .SpecialCells(xlCellTypeConstants, 16).EntireColumn.Delete
        .ClearContents
    End With
    '---actualise les barres de défilement---
    With .UsedRange: End With
End With
End Sub
A+
 
Dernière édition:
Re,

J'ai testé la macro précédente sur un tableau de 54 000 lignes avec 27 000 lignes vides disjointes => 2 minutes environ.

Pour aller vite il faut trier le tableau sur les [Edit] colonne et ligne auxiliaires :
Code:
Sub SupprimerLignesColonnes()
Application.ScreenUpdating = False
On Error Resume Next 'si aucune SpecialCell
With ActiveSheet 'à adapter
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    '---suppression des lignes vides---
    With .UsedRange.Columns(.UsedRange.Columns.Count + 1)
        .FormulaR1C1 = "=1/COUNTA(RC1:RC[-1])"
        .Value = .Value
        .EntireRow.Sort .Cells, xlAscending, Header:=xlNo, Orientation:=xlByRows 'tri vertical
        .SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete
        .ClearContents
    End With
    '---suppression des colonnes vides---
    With .UsedRange.Rows(.UsedRange.Rows.Count + 1)
        .FormulaR1C1 = "=1/COUNTA(R1C:R[-1]C)"
        .Value = .Value
        .EntireColumn.Sort .Cells, xlAscending, Header:=xlNo, Orientation:=xlByColumns 'tri horizontal
        .SpecialCells(xlCellTypeConstants, 16).EntireColumn.Delete
        .ClearContents
    End With
    '---actualise les barres de défilement---
    With .UsedRange: End With
End With
End Sub
Avec le tableau de 27 000 lignes vides => 4 secondes.

A+
 
Dernière édition:
Re-

Sur 45000 lignes, encore plus rapide en mixant la proposition #4 et le tri proposé en #6.
J'arrive à moins de 0.5 secondes et 3.5 secondes sur proposition #6.
Tout cela me convient très bien 😎.

@+ zebanx

VB:
Function colstring(colonne&)
'---àpd numéro de colonne
colstring = Split(Columns(colonne).Address(columnAbsolute:=False), ":")(1)
End Function
Sub sh05_supp_RC_vides_sommeproduct()
Dim plage1 As Range, plage2 As Range
Dim dercol&, derligne&, r2cd$, r2cf$
t0 = Timer

On Error Resume Next
dercol = Cells(1, Columns.Count).End(1).Column
col$ = colstring(dercol)
derligne = Cells(Rows.Count, 1).End(3).Row
Set plage1 = Range(Cells(derligne, 1), Cells(derligne, dercol))
Application.ScreenUpdating = False

'--- supprimer colonnes
With plage1.Offset(1, 0)
  .Formula = "=1/(1/SUMPRODUCT(N(A2:A" & derligne - 1 & "<>"""")))"
  .Value = .Value
  Columns("A:" & col$).Sort Key1:=Range("A1"), Order1:=xlAscending, Orientation:=xlLeftToRight
  .SpecialCells(xlCellTypeConstants, 16).EntireColumn.Delete
  .Value = ""
End With

dercol = Cells(1, Columns.Count).End(1).Column
Set plage2 = Range(Cells(2, dercol), Cells(derligne, dercol))
r2cd = Cells(2, 1).Address(0, 0)
r2cf = Cells(2, dercol).Address(0, 0)

'--- supprimer lignes
With plage2.Offset(0, 1)
  '.Formula = "=1/(1/SUMPRODUCT(N(A2:" & r2cf & "<>"""")))"
  .Formula = "=1/(1/SUMPRODUCT(N(" & r2cd & ":" & r2cf & "<>"""")))"
  .Value = .Value
  Rows("2:" & derligne).Sort .Cells, xlAscending, Header:=xlNo, Orientation:=xlByRows 'tri vertical
  .SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete
  .Value = ""
End With

With ActiveSheet.UsedRange: End With '---actualise les barres de défilement
MsgBox Format(Timer - t0, "0.000\sec.")
Application.ScreenUpdating = True
End Sub
 
Et une variante aussi rapide (il faut conserver la fonction colstring quand même dont le code a été présenté en #8)

VB:
Sub sh05_supp_RC_vides_countblank()
Dim plage1 As Range, plage2 As Range
Dim dercol&, derligne&, r2cd$, r2cf$

t0 = Timer
dercol = Cells(1, Columns.Count).End(1).Column
col$ = colstring(dercol)
derligne = Cells(Rows.Count, 1).End(3).Row
Set plage1 = Range(Cells(derligne, 1), Cells(derligne, dercol))
Application.ScreenUpdating = False
On Error Resume Next

'--- supprimer colonnes
With plage1.Offset(1, 0)
  .Formula = "=1/(COUNTBLANK(A2:A" & derligne & ")>" & (derligne - 2) & ")*1"
  .Value = .Value
  Columns("A:" & col$).Sort Key1:=Range("A1"), Order1:=xlAscending, Orientation:=xlLeftToRight
  .SpecialCells(xlCellTypeConstants, 3).EntireColumn.Delete
  .Value = ""
End With

dercol = Cells(1, Columns.Count).End(1).Column
Set plage2 = Range(Cells(2, dercol), Cells(derligne, dercol))
r2cd = Cells(2, 1).Address(0, 0)
r2cf = Cells(2, dercol).Address(0, 0)

'--- supprimer lignes
With plage2.Offset(0, 1)
  '.Formula = "=1/(1/SUMPRODUCT(N(" & r2cd & ":" & r2cf & "<>"""")))"
.Formula = "=1/(COUNTBLANK(" & r2cd & ":" & r2cf & ")>" & (dercol - 2) & ")*1"
.Value = .Value
Rows("2:" & derligne).Sort .Cells, xlAscending, Header:=xlNo, Orientation:=xlByRows 'tri vertical
.SpecialCells(xlCellTypeConstants, 3).EntireRow.Delete
.Value = ""
End With
With ActiveSheet.UsedRange: End With '---actualise les barres de défilement

MsgBox Format(Timer - t0, "0.000\sec.")
Application.ScreenUpdating = True
End Sub
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
13
Affichages
203
Réponses
6
Affichages
534
Réponses
25
Affichages
606
Réponses
5
Affichages
399
Retour