Concatener plusieurs lignes

[miliev83]

Bonjour,
Je souhaite regrouper le contenu des lignes de la colonne R et S lorsque dans la colonne A cela concerne le même identifiant.

Voici le code :

Option Explicit
Private Sub Concatener_Click()
Dim DerLigD As Long, LigneC As Long
Dim Dico, k
Dim C As Range
Dim WsC As Worksheet
Dim n As Integer
Dim Texte As String
    Application.ScreenUpdating = False
    With Worksheets("feuil1")
        DerLigD = .Range("A" & Rows.Count).End(xlUp).Row
        Set Dico = CreateObject("Scripting.dictionary")
        Set WsC = Worksheets("feuil2")
        For Each C In .Range("A2:A" & DerLigD)
           If Not Dico.Exists(C.Value) Then Dico.Add C.Value, C.Offset(0, 1).Value
        Next C
        k = Dico.keys
        LigneC = 2
        WsC.Range("A2:B" & WsC.Range("A1").End(xlDown).Row).ClearContents
        For n = 0 To Dico.Count - 1
            WsC.Range("A" & LigneC).Value = k(n)
            For Each C In .Range("A1:A" & DerLigD)
                If C = k(n) Then Texte = Texte & C.Offset(0, 1) & Chr(10)
            Next C
            WsC.Range("B" & LigneC).Value = Left(Texte, Len(Texte) - 1)
            Texte = ""
            LigneC = LigneC + 1
        Next n
        Set WsC = Nothing: Set Dico = Nothing
    End With
End Sub

Merci d'avance!!

 

[Papou-net]

Re : Concatener plusieurs lignes

Bonsoir miliex83,

Essaie en modifiant ton code comme ceci:

Private Sub Concatener_Click()
Dim DerLigD As Long, LigneC As Long
Dim Dico, k
Dim C As Range
Dim WsC As Worksheet
Dim n As Integer
Dim TexteB As String, TexteC As String
    Application.ScreenUpdating = False
    With Worksheets("feuil1")
        DerLigD = .Range("A" & Rows.Count).End(xlUp).Row
        Set Dico = CreateObject("Scripting.dictionary")
        Set WsC = Worksheets("feuil3")
        For Each C In .Range("A2:A" & DerLigD)
           If Not Dico.Exists(C.Value) Then Dico.Add C.Value, C.Offset(0, 1).Value
        Next C
        k = Dico.keys
        LigneC = 2
        WsC.Range("A2:B" & WsC.Range("A1").End(xlDown).Row).ClearContents
        For n = 0 To Dico.Count - 1
            WsC.Range("A" & LigneC).Value = k(n)
            For Each C In .Range("A1:A" & DerLigD)
                If C = k(n) Then
                  TexteB = TexteB & C.Offset(0, 17) & Chr(10)
                  TexteC = TexteC & C.Offset(0, 18) & Chr(10)
                End If
            Next C
            WsC.Range("B" & LigneC).Value = TexteB
            WsC.Range("C" & LigneC).Value = TexteC
            TexteB = "": TexteC = ""
            LigneC = LigneC + 1
        Next n
        Set WsC = Nothing: Set Dico = Nothing
    End With
End Sub

A +

Cordialement.

 

[miliev83]

Re : Concatener plusieurs lignes

Merci Papou-net, ta macro donne le résultat attendu à 2 3 détails près mais c'est ma faute je n'ai pas donné toutes les infos dès le départ, je m'explique :

En fait, je souhaiterai récupérer seulement les info des identifiants qui ont une donnée dans la colonne R ou S
Est-il possible également de ne pas avoir les sauts de ligne dans les cellules avant et après le texte ?

Merci encore

 

[Papou-net]

Re : Concatener plusieurs lignes

RE:

Voici donc une version corrigée.

J'en ai profité pour simplifier la structure de la macro ce qui permet d'accélérer son déroulement.

Private Sub Concatener_Click()
Dim Cel As Range, lgC As Long

lgC = 1
Application.ScreenUpdating = False
With Feuil2
  .Range("A:C").ClearContents
  .Range("A1") = Feuil1.Range("A1")
  .Range("B1") = Feuil1.Range("B1")
  .Range("C1") = Feuil1.Range("C1")
  For Each Cel In Feuil1.Range("A2:A" & Rows.Count).SpecialCells(xlCellTypeConstants)
    If ((Cel.Offset(0, 17) = "") * 1) * ((Cel.Offset(0, 18) = "") * 1) = False Then
      If Cel = Cel.Offset(-1, 0) And ((Cel.Offset(0, 17) = "") * 1) * ((Cel.Offset(0, 18) = "") * 1) = False Then
        .Cells(lgC, 2) = .Cells(lgC, 2) & Chr(10) & Cel.Offset(0, 17)
        .Cells(lgC, 3) = .Cells(lgC, 3) & Chr(10) & Cel.Offset(0, 18)
        Else
        lgC = lgC + 1
        .Cells(lgC, 1) = Cel
        .Cells(lgC, 2) = Cel.Offset(0, 17)
        .Cells(lgC, 3) = Cel.Offset(0, 18)
      End If
    End If
  Next
End With
Application.ScreenUpdating = True
End Sub

Bonne soirée.

Cordialement

 

[miliev83]

Re : Concatener plusieurs lignes

Merci Papou-net, c'est presque parfait mais c'est encore de ma faute désolé

J'ai oublié de demander, lorsque cela concatène est il possible de ne pas répéter les doublons dans des colonnes R et S ?

 

[miliev83]

Re : Concatener plusieurs lignes

Voici mon fichier avec doublons et le résultat souhaité

 

[miliev83]

Re : Concatener plusieurs lignes

----------------------

 

[klin89]

Re : Concatener plusieurs lignes

Bonsoir le forum, miliev83

A tester, restitution en Feuil3.

Option Explicit

Sub test()
Dim a, i As Long, j As Long, n As Long, w()
    ReDim w(1 To 3)
    With Sheets("Feuil1").Range("A1").CurrentRegion
        a = Application.Index(.Value, Evaluate("row(1:" & _
                         .Rows.Count & ")"), Array(1, 18, 19))
        n = 1
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 2 To UBound(a, 1)
                If Not .exists(a(i, 1)) Then
                    n = n + 1
                    w(1) = n
                    For j = 2 To UBound(a, 2)
                        Set w(j) = _
                        CreateObject("Scripting.Dictionary")
                        w(j).CompareMode = 1
                        If (a(i, j)) <> "" Then
                            w(j)(a(i, j)) = Empty
                        End If
                    Next
                    For j = 1 To UBound(a, 2)
                        a(n, j) = a(i, j)
                    Next
                    .Item(a(i, 1)) = w
                Else
                    w = .Item(a(i, 1))
                    For j = 2 To UBound(a, 2)
                        If a(i, j) <> "" Then
                            If Not w(j).exists(a(i, j)) Then
                                If a(w(1), j) <> "" Then
                                    a(w(1), j) = Join$(Array(a(w(1), j), a(i, j)), " - ")
                                Else
                                    a(w(1), j) = a(i, j)
                                End If
                                w(j)(a(i, j)) = Empty
                                .Item(a(i, 1)) = w
                            End If
                        End If
                    Next
                End If
            Next
        End With
    End With
    'Restitution
    Application.ScreenUpdating = False
    With Sheets("Feuil3").Cells(1)
        .CurrentRegion.Clear
        .Parent.Columns("b:c").NumberFormat = "@"
        With .Resize(n, UBound(a, 2))
            .Value = a
            .Font.Name = "Calibri"
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            .Borders(xlInsideHorizontal).Weight = xlThin
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
            With .Rows(1)
                .Interior.ColorIndex = 36
            End With
            .Columns.AutoFit
        End With
        .Parent.Activate
    End With
    Application.ScreenUpdating = True
End Sub

Bonne nuit
klin89

 

[miliev83]

Re : Concatener plusieurs lignes

ca marche merci!!