XL 2016 Supprimer fusions et décaler données

Amilo · 5 Août 2017

Bonjour le forum,

Dans le tableau ci-joint, je souhaiterais supprimer les zones fusionnées (cellules en jaune),
Une fois les zones défusionnées, je souhaiterais supprimer les zones vides en décalant les données vers la gauche.
Je ne souhaite pas supprimer les fusions pour les zones en vert,

J'ai testé le code ci-dessous qui a l'air de fonctionner mais je rencontre 2 problèmes :
- je ne sais pas comment indiquer dans le code que le tableau démarre de la ligne A5 et rendre la dernière ligne Q23 dynamique car la hauteur du tableau varie d'un export à l'autre.
J'ai tenté avec "Selection.End(xlDown))" mais en vain....
- et éventuellement décaler la zone en rouge vers la gauche de façon que celle-ci soit alignée avec la dernière colonne du tableau

De plus je ne suis pas certain que ce code soit adapté mais si vous avez plus simple je suis preneur.

P.S : En réalité mon tableau perso fait plus de 20 000 lignes

Merci d'avance pour votre aide

Code:

Sub SpprimerDecaler()
Dim Data As Range, Lig, Col
Set Data = Range("A5:Q23")
Application.ScreenUpdating = False
With Data
For Lig = 1 To .Rows.Count
For Col = .Columns.Count To 1 Step -1
If .Cells(Lig, Col) = "" Then .Cells(Lig, Col).Delete shift:=xlToLeft
Next Col
Next Lig
End With
Application.ScreenUpdating = True
End Sub

gosselien · 5 Août 2017

Bonjour,

essaie ceci et oui ! ilFAUT supprimer les fusions de cellules

P.

VB:

Sub SpprimerDecaler()
Dim Data As Range, Lig, Col
Dim LastR, LastC As Long
LastC = Cells.Find("*", [A1], SearchDirection:=xlPrevious).Column
LastR = [A65000].End(xlUp).Row
Set Data = Range("A5:Q" & LastR)
Application.ScreenUpdating = False
With Data
   For Lig = 1 To .Rows.Count
      For Col = .Columns.Count To 1 Step -1
         If .Cells(Lig, Col) = "" Then .Cells(Lig, Col).Delete shift:=xlToLeft
      Next Col
   Next Lig
End With
Application.ScreenUpdating = True
End Sub

Amilo · 5 Août 2017

Bonjour gosselien,,
Merci beaucoup pour votre réponse et cette solution,
J'ai simplement modifié la valeur de ces 2 lignes ci-dessous en indiquant B65000 au lieu de A65000 et "A5:Q" par "A5:S" et cela fonctionne très bien quelque soit la taille du tableau.

Pour l'autre problème de décaler les cellules en rouge, je pense que je ferai cela manuellement, ça me prendra 3 secondes...

Code:

LastR = [B65000].End(xlUp).Row
Set Data = Range("A5:S" & LastR)

Merci encore à vous
Bonne journée

Amilo · 5 Août 2017

Re,

Désolé, finalement le code met énormément de temps sur mon fichier perso qui fait plus de 25 000 lignes et je suis obligé de l''arrêter après 2mn,
Il doit y avoir une autre procédure beaucoup plus rapide je pense,
Avez-vous svp une solution ?

Merci d'avance

Cordialement

gosselien · 5 Août 2017

Amilo à dit:
Re,

Désolé, finalement le code met énormément de temps sur mon fichier perso qui fait plus de 25 000 lignes et je suis obligé de l''arrêter après 2mn,
Il doit y avoir une autre procédure beaucoup plus rapide je pense,
Avez-vous svp une solution ?

Merci d'avance

Cordialement

Comme quoi les fusions.... ça fout le boxon mais je suppose que tu reçois le document comme ça ?

Avez-vous svp une solution

moi non, mais d'autres sûrement

Amilo · 5 Août 2017

gosselien,
Oui j'obtiens ce fichier après un import avec une application de gestion de stock,
Je vais peut-être essayer d'enregistrer l'extension .xlsx en .xlsb mais je ne pense pas que ça va changer beaucoup,
Bonne journée

gosselien · 5 Août 2017

Je n'ai pas mieux que ceci...

VB:

Sub SpprimerDecaler()
Dim Data , Zaza As Range, Lig, Col
Dim LastR, LastC As Long
LastC = Cells.Find("*", [A1], SearchDirection:=xlPrevious).Column
LastR = [A65000].End(xlUp).Row
Set Data = Range("A5:Q" & LastR)
Application.ScreenUpdating = False
With Data
   For Lig = 1 To .Rows.Count
      For Col = .Columns.Count To 1 Step -1
         If .Cells(Lig, Col) = "" Then .Cells(Lig, Col).Delete shift:=xlToLeft
      Next Col
   Next Lig
End With
Application.ScreenUpdating = True
For Each zaza In Data
   If zaza.MergeCells Then
       zaza.MergeCells = False
   End If
Next
End Sub

Amilo · 5 Août 2017

Merci gosselien pour cette autre solution mais malheureusement c'est pareil,
J'ai un autre code ci-dessous qui supprime les colonnes fusionnées en 3 sec sur le classeur perso de 25000 lignes,¨

Code:

Sub SpprimerDecaler()
Dim Data As Range
Set Data = Range("A5:S" & [B65000].End(xlUp).Row)
  Application.ScreenUpdating = False
With Data
    .UnMerge
  End With
Application.ScreenUpdating = True
End Sub

Les colonnes D, E, G, H, R et S sont défusionnées et entièrement vidées, ce sont ces colonnes là que je cherche à supprimer du tableau mais dans la limite des cellules en jaune.

Lorsque je veux décaler à gauche les cellules vides du tableau avec une macro, je n'obtiens pas le résultat souhaité car j'ai malheureusement quelques cellules vides parsemées ici ou là dans d'autres colonnes du tableau.
Les 2 macros fonctionnent en 20 sec env., ce qui est encore beaucoup mais surtout avec l'erreur évoquée plus haut.
Au pire, je ferais la suppression manuellement en attendant que je progresse en VBA.....qui sait !

Bonne soirée à tous

pierrejean · 7 Août 2017

Bonjour

Code a tester pour 1er décalage

Code:

Sub SpprimerDecalerb()
For n = Range("A" & Rows.Count).End(xlUp).Row To 5 Step -1
  If Not Range("A" & n).MergeCells Then
      Range("C5:H" & n).MergeCells = False
      Range("Q5:S" & n).MergeCells = False
      Range("R5:S" & n).Delete xlShiftToLeft
      Range("G5:H" & n).Delete
      Range("D5:E" & n).Delete
      Exit For
  End If
Next
End Sub

Amilo · 7 Août 2017

Bonjour pierrejean, le forum,

Super et mille merci pour cette solution qui fonctionne très bien en env. 14 sec,
Il est vrai que je n'avais pas précisé d'emblée que certaines colonnes comportaient quelque fois des cellules vides, d'où le risque d'avoir des propriétés ou méthodes inadaptées
Merci à vous et à gosselien pour votre soutien

Bonne journée

XL 2016 Supprimer fusions et décaler données

Amilo

XLDnaute Accro

Pièces jointes

gosselien

XLDnaute Barbatruc

Amilo

XLDnaute Accro

Amilo

XLDnaute Accro

gosselien

XLDnaute Barbatruc

Amilo

XLDnaute Accro

gosselien

XLDnaute Barbatruc

Amilo

XLDnaute Accro

pierrejean

XLDnaute Barbatruc

Amilo

XLDnaute Accro

Discussions similaires