Suppression colonnes vides

Bonjour à toutes et à tous

voilà serait il possible d'avoir une macro vba excel qui me décalerait les colonnes vers la gauche dès qu'il y a une colonne vide dans la feuille active et uniquement à partir de la colonne "J" jusqu'à la colonne "AB" par contre dans la feuille qui contient en général entre 1500 et 3000 lignes cette dernière est divisée en blocs différents qui sont séparés par des lignes vides donc il faudrait décaler bloc par bloc. je vous joins un fichier pour une meilleure compréhension j'ai bien une macro vba mais elle ne fonctionne pas je vous la joins également.

Sub DeplacerColonnes()
    Dim plage As Range
    Dim bloc As Range
    Dim derniereColonne As Integer
    Dim colonne As Range

    Set plage = ActiveSheet.UsedRange

    ' Parcourir chaque bloc de données séparés par des lignes vides
    For Each bloc In plage.Rows
        ' Trouver la dernière colonne occupée dans le bloc
        derniereColonne = bloc.Columns(bloc.Columns.Count).End(xlToLeft).Column

        ' Décaler les colonnes occupées vers la gauche s'il y a une colonne vide
        For Each colonne In bloc.Columns("J:Z")
            If Application.WorksheetFunction.CountA(colonne) < bloc.Rows.Count Then
                colonne.Resize(, derniereColonne - colonne.Column + 1).Cut
                colonne.Offset(, 1).Insert Shift:=xlToRight
            End If
        Next colonne
    Next bloc
End Sub

Bonjour à tous,

Bonjour Berjac,

Dans un premier temps, il faut que tu détermines les plages à traiter pour les parcourir une à une.

Ensuite, tu pourras boucler avec cet exemple de macro :

Sub supprime_colonnes_vides()
    Dim i As Long
    With Range("j2:y17")
        '.Select
        For i = .Columns.Count To 1 Step -1
            If Application.CountA(.Columns(i)) = 0 Then .Columns(i).Delete
        Next
    End With
End Sub

A tester sur des copies de tes données, c'est préférable.

klin89

Bonjour,

Attention ! Je crois que Columns(i) cible la colonne entière et ce sur l'ensemble des plages qui ne sont pas identique.
Il faut utiliser je pense un code de ce type : Range("G2:G20").Delete Shift:=xlToLeft, parce qu'en fait on ne supprime pas des colonnes mais une plage de cellules verticales et on glisse ce qui reste vers la gauche.

@ bientôt

LouReeD

@LouReed, c'est ce que je pensais aussi et j'ai testé sur 2 plages à la vas vite et ça m'a l'air d'être bon.

klin89

Ok,

je n'ai pas testé de mon côté... Sinon je propose ce code qui "trouve" les différentes plages :

Sub testLRD()
    Dim I, J, Lig, Fin, Deb, DerLig
    ' on boucle la colonne A afin de trouver les groupes de plages
    Lig = 1
    Deb = 1
    Fin = 0
    DerLig = Range("A" & Rows.Count).End(xlUp).Row
    ' on boucle la colonne A afin de trouver les groupes de plages
    For I = 1 To DerLig
        ' première cellule non vide
        If Cells(I, 1) <> "" Then
            ' si on n'a pas affecter cette ligne à début on le fait
            If Deb = 0 Then Deb = I
        ' si la cellule est vide
        Else
            ' et que l'on a pas affecté à Fin on affecte la ligne du dessus
            If Fin = 0 Then Fin = I - 1
        End If
        ' si I = dernière ligne non vide de la colonne alors Fin = I
        If I = DerLig And Fin = 0 Then Fin = DerLig

        ' si on a déterminé un début et une fin de zone
        If Deb > 0 And Fin > 0 Then
            ' on scanne les colonnes à l'envers
            For J = 28 To 10 Step -1
                ' si le nombre d evaleur dans la colonne de début à fin = 0
                If Application.CountA(Range(Cells(Deb, J), Cells(Fin, J))) = 0 Then
                    ' on efface les cellules avec un scroll vers la gauche
                    Range(Cells(Deb, J), Cells(Fin, J)).Delete Shift:=xlToLeft
                End If
            Next
            ' la zone définie est finie, on réinitialise début et fin à 0
            Deb = 0: Fin = 0
        End If
    ' on continue la boucle sur la colonne A
    Next I
End Sub

Le fichier où l'on doit supprimer les cellules jaunes afin de "coller" les rouge et vertes :

@ bientôt

LouReeD

Et ben j'en apprends tous les jours !

Donc le code peut se simplifier avec un mix des deux !

@ bientôt

LouReeD

Voilà,

c'est fusionné !

Sub testLRD()
    Dim I, J, Lig, Fin, Deb, DerLig
    ' on boucle la colonne A afin de trouver les groupes de plages
    Lig = 1
    Deb = 1
    Fin = 0
    DerLig = Range("A" & Rows.Count).End(xlUp).Row
    ' on boucle la colonne A afin de trouver les groupes de plages
    For I = 1 To DerLig
        ' première cellule non vide
        If Cells(I, 1) <> "" Then
            ' si on n'a pas affecter cette ligne à début on le fait
            If Deb = 0 Then Deb = I
        ' si la cellule est vide
        Else
            ' et que l'on a pas affecté à Fin on affecte la ligne du dessus
            If Fin = 0 Then Fin = I - 1
        End If
        ' si I = dernière ligne non vide de la colonne alors Fin = I
        If I = DerLig And Fin = 0 Then Fin = DerLig

        ' si on a déterminé un début et une fin de zone
        If Deb > 0 And Fin > 0 Then
            With Range("J" & Deb & ":AB" & Fin)
                For J = .Columns.Count To 1 Step -1
                    If Application.CountA(.Columns(J)) = 0 Then .Columns(J).Delete
                Next
            End With
            ' la zone définie est finie, on réinitialise début et fin à 0
            Deb = 0: Fin = 0
        End If
    ' on continue la boucle sur la colonne A
    Next I
End Sub

@ bientôt

LouReeD

Bonjour et un grand merçi à vous pour votre dévouement

par contre dans les données il y a un décalage dans les blocs je vous joins un fichier que vous pourrez tester

sinon le principe est excellent je vous remerçie

Jacques

Re

Pour faire simple, j'ai considéré que l'on partait sur des blocs constitués de 19 colonnes maxi à partir de la colonne J, le nombre de lignes d'un bloc à traiter étant déterminé par la colonne 2.

Sub Supprime_colonnes_vides()
    Dim r As Range, rng As Range, i As Long
    Application.ScreenUpdating = False
    'With Sheets("Avant")
    With Sheets(1) 'sur une copie placee en 1ere position
        For Each r In .Columns(2).SpecialCells(2, 1).Areas
            Set rng = r.Offset(, 8).Resize(, 19) 'le bloc a traiter jusqua la colonne ab
            'rng.Select
            With rng
                For i = .Columns.Count To 1 Step -1
                    If Application.CountA(.Columns(i)) = 0 Then .Columns(i).Delete
                Next
            End With
        Next
    End With
    Application.ScreenUpdating = True
End Sub

Ça m'a l'air de coller

klin89

Alors là ! J'apprends, j'apprends, j'apprends !

9 ? j'ai copié y a pas longtemps et c'était 17 Oui du coup aves 19 c'est génial ! Faut que je regarde le code de plus près.
Le for Each r permet d'aller de bloc en bloc par "aera" de cellules, c'est bien cela ?

Ce bloc colonne 2 on le déplace en colonne J puis on le redimensionne en 19 colonnes de largeur.
Après c'est le reste du code du début !

Je commence à saisir le truc. Mais le SpecialCells(2, 1).Areas ? Il permet de mettre "en mémoire" les suite de cellule sans trous de la colonne 2 ?

Avec un vilain jeu de mot c'est Klin ! (clean !), mais n'y a t il pas un petit décalage, j'ai encadré les données de vert et de rouge afin de voir le résultat où le jaune doit disparaitre :

@ bientôt

LouReeD

Bonsoir Klin89 Et Lou Reed

voilà le code fonctionne avec le morceau de fichier que je vous ai transmis mais avec un fichier complet ça me fait des erreurs je vais essayer de vous mettre un fichier complet qui est beaucoup plus long

bonne soirée à vous deux et encore mille merçis

Jacques

Bonjour à tous,

je voulais juste rajouter que quelque soit e fichier, il y a toujours trois lignes entre chaque bloc de données de la colonne "J" à "Z"

par contre ce n'est pas toujours le cas dans les autres colonnes il n'y a parfois que deux lignes

bonjour le fil,

un autre essai

Sub test()
     Dim UN    As Range, ar, c, t

     t = Timer
     With Sheets("sheet1")                   'la feuille
          Set c = .UsedRange.Offset(, 27 - .UsedRange.Column).Resize(, 1)     'colonne AA = auxiliaire
          c.FormulaR1C1 = "=if(COUNTA(RC1:RC26)>0,1,"""")"     'formule pour voir si la ligne est vide ou pas
          c.Value = c.Value                  'remplacer formule par valeur

          For Each ar In c.SpecialCells(xlConstants).Areas     'boucler les plages "Constants"
               Set UN = ar                   'commencer avec ces nouvelles formules/valeurs
               For i = .Columns("J").Column To 26     'boucler de la colonne J à Z
                    Set c1 = ar.Offset(, i - ar.Column)     'cette plage
                    If WorksheetFunction.CountA(c1) = 0 Then Set UN = Union(UN, c1)     'si vide ajouter à UN
               Next

               UN.Delete shift:=xlToLeft     'supprimer UN
          Next
          .Range("A1:Z1").EntireColumn.AutoFit
     End With

     MsgBox Timer - t
End Sub

Bonjour à tous et merçi à toi Bart,

Ta macro fonctionne très bien par contre pourrait on la faire fonctionner sur la feuille active et garder les colonnes dans les memes largeurs après l'exécution de la macro

Merçi Bart et merçi à tous ceux qui ont participé

Jacques

re,

merci

pour les largeurs, c'est supprimer ceci

.Range("A1:Z1").EntireColumn.AutoFit

et pour la feuille active c'est remplacer

With Sheets("sheet1") par With Activesheet

Bonsoir Bart ,

tu es un as encore bravo et merçi

et merçi à tout le monde

Jacques

Ps je vais lancer un autre sujet que je n'arrive pas à résoudre j'ai toujours des erreurs

Bonsoir,

je prend une toute petite partie de vos remerciement et je m'éloigne discrètement ! BsAlv, encore une fois : joli, pour ne pas me répéter !

@ bientôt

LouReeD

bonsoir LouReed

mais je te remerçie grandement de ton aide car cela m'apporte un peu plus de connaissance et je vous remerçie tous pour votre dévouement

au plaisir

Jacques

Alors là, je les prends en entier vos remerciements !

@ bientôt

LouReeD