XL 2010 VBA Macro pour supprimer une colonne sur deux

[jlbcall]

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

 

[job75]

Bonsoir jlbcall,

Cette macro supprime toutes les colonnes vides, un point c'est tout :

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+

 

[jlbcall]

Merci Job75 et je te souhaite une belle journée

 

[zebanx]

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

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

 

[job75]

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 :

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+

 

[job75]

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 :

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+

 

[zebanx]

Merci beaucoup JOB75
Je regarde cela avec grand intérêt

@+

 

[zebanx]

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

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

 

[zebanx]

Et une variante aussi rapide (il faut conserver la fonction colstring quand même dont le code a été présenté en #8)

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