Excel: multicellules à remettre dans une seule cellule Fermé

Question

Bonjour,

Je m'excuse d'avance car le sujet a surement déjà été traité dans votre forum mais mes recherches sur internet n'ont rien donné. (mauvais intitulé?)

J'ai un export EXCEL d'environ 6000 lignes mais celui-ci comporte des données avec des cellules réparties sur plusieurs lignes (voir capture d'écran)



Je souhaite CONCATÉNER /fusionner/supprimer pour avoir en final un fichier avec à chaque fois sur une seule ligne avec l'intitulé A et les autres colonnes fusionnées sans pertes. 

Exemple: concaténation avec retour ligne des cellules A5 à A8, C5 à C8, D5 à D8.

Une idée de code VBA? 

Merci pour votre aide. 

Pierre

pijaku · Answer

Bonjour,

Plutôt qu'une image, un fichier exemple d'une trentaine de lignes  serait un bon départ...
Tu laisses 30 et quelques lignes de ton fichier comme il est ainsi que ce que tu veux obtenir à la fin.

Pour joindre un fichier, il faut passer par cjoint.fr créer un lien vers ton fichier et revenir ici coller le lien dans ta réponse.

PierreC1977 · Answer

Voici un exemple avec la situation incorrecte et la situation corrigée pour compléter ma question.

https://www.cjoint.com/c/EFimUsUtvhq

Frenchie83 · Answer

Bonjour
A essayer
Sub MiseEnForme()
    Application.ScreenUpdating = False
    'Suppression de la fusion des cellules
    Columns("A:E").UnMerge
    DerLig = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
    
    'Remplissge colonne D
    For i = 2 To DerLig
        If Cells(i, 1) <> "" Then
            LigDep = i
        Else
            'vérifie si le texte trouvé est déjà présent dans les cellules destinations
            ValColD = InStr(1, Cells(LigDep, 4), Cells(i, 4), 1)
            If ValColD = 0 Then Cells(LigDep, 4) = Cells(LigDep, 4) & Chr(10) & Cells(i, 4) & ","
            
            ValColE = InStr(1, Cells(LigDep, 5), Cells(i, 5), 1)
            If ValColE = 0 Then Cells(LigDep, 5) = Cells(LigDep, 5) & Chr(10) & Cells(i, 5) & ","
        End If
    Next i
    
    'Suppression des lignes inutiles
    For i = DerLig To 2 Step -1
        If Cells(i, 1) = "" Then Rows(i).EntireRow.Delete
    Next i
        
    'suppression des espaces, virgules et retour chariot inutiles
    For i = 2 To [A100000].End(xlUp).Row
        For j = 4 To 5
            Cells(i, j) = LTrim(Cells(i, j))
            If Left(Cells(i, j), 2) = Chr(10) & "," Then Cells(i, j) = Right(Cells(i, j), Len(Cells(i, j)) - 3)
            If Left(Cells(i, j), 1) = "," Then Cells(i, j) = Right(Cells(i, j), Len(Cells(i, j)) - 1)
        Next j
    Next i
    
    'suppression des virgules doubles
    Columns("D:E").Select
    Selection.Replace What:=",,", Replacement:=",", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End Sub

Cdlt