CONCATENER

Bonjour,

N'ayant pas trouvé de solution à mon problème sous Libre Office Base, je cherche une solution alternative sous Excel.

Il s'agit d'une base de donnée de visites d'appartement effectuées par une agence immobilière. J'ai effectué une requête qui me donne les visites effectuées au mois de janvier et de février.

Par la suite, j'utilise un tableau croisé dynamique pour regrouper les données par propriétaire, puis par appartement.

Je souhaiterais concaténer les données pour que celles-ci n'apparaissent que sur une ligne par propriétaire afin de réaliser un publipostage.

En pièce-jointe, vous trouverez un fichier avec un onglet résultat obtenu et un onglet résultat voulu.

Merci d'avance

Bonjour,

Si tu me permets un conseil ...

Ce n'est pas le résultat voulu ... qu'il faut poursuivre ... mais le résultat souhaité ...

Bonjour James 007!

Merci d'avoir pris le temps de me répondre, et merci pour la petite correction de français, il est vrai que le terme "voulu" n'était peut-être pas approprié.

Cependant, la solution que tu me proposes est à l'opposé exact de ce que je cherche à obtenir. A vrai dire, je me demande si c'est possible, et/ou si je m'exprime vraiment très mal.

Je joins à ce post un imprim écran du résultat de la requête sous libre office, qui est la première étape.

Deuxième étape : je récupère les données sous Calc que je synthétise grâce à un tableau croisé dynamique.

Etape trois (mais est-ce possible???) : concaténer le résultat obtenu dans le TCD pour que les données soit regroupées dans une seule ligne, afin que je puisse réaliser un publipostage.

D'avance merci à tous ceux qui auront pris le temps de me lire et d'essayer de comprendre ce que je cherche à faire.

Bonsoir le forum,

Avec le fichier fourni par James 007

Résultat à côté du tableau initial en Feuille3

Les références-biens doivent rester triées

Option Explicit
Sub fusion()
Dim a, i As Long, j As Long, n As Long, dico As Object, w
    With Sheets(3).Range("A1").CurrentRegion
        a = .Value
        ReDim b(1 To UBound(a, 1), 1 To 3)
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 1 To UBound(a, 1)
                If Not .exists(a(i, 1)) Then
                    n = n + 1
                    Set dico = CreateObject("Scripting.Dictionary")
                    dico.CompareMode = 1
                    For j = 1 To UBound(a, 2)
                        b(n, j) = a(i, j)
                        If j < 3 Then
                            If a(i, j) <> "" Then dico(a(i, j)) = Empty
                        End If
                    Next
                    .Item(a(i, 1)) = VBA.Array(n, dico)
                Else
                    w = .Item(a(i, 1))
                    For j = 1 To UBound(a, 2)
                        If j < 3 Then
                            If a(i, j) <> "" And Not w(1).exists(a(i, j)) Then
                                b(w(0), j) = b(w(0), j) & Chr(10) & a(i, j)
                                w(1)(a(i, j)) = Empty
                            ElseIf j = 2 Then
                                b(w(0), j) = b(w(0), j) & Chr(10)
                            Else
                            End If
                        End If
                    Next
                    b(w(0), 3) = b(w(0), 3) & Chr(10) & a(i, 3)
                End If
            Next
        End With
        Application.ScreenUpdating = False
        With .Offset(, .Columns.Count + 1)
            .CurrentRegion.Clear
            With .Resize(n, UBound(b, 2))
                .Value = b
                With .CurrentRegion
                    .Columns(1).Interior.ColorIndex = 19
                    .Font.Name = "calibri"
                    .Font.Size = 10
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlTop
                    .Borders(xlInsideHorizontal).Weight = xlThin
                    .Borders(xlInsideVertical).Weight = xlThin
                    .BorderAround Weight:=xlThin
                    .Rows.AutoFit
                    .Columns.AutoFit
                End With
            End With
            .Parent.Select
        End With
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Bonjour,

Salut Klin89 ... et bravo pour ta macro dictionnaire ...

Je me suis très mal exprimé ...

Le problème structurel est que pour tout utilisateur d'Excel ... il faut impérativement banir les cellules fusionnées ...

Car elles sont l'ennemi juré par excellence ... et empêcheront ensuite les données d'être manipulées ...

S'il te faut absolument ce genre de tableau ... il existe un logiciel adapté : Word ...

Bonsoir le forum, Annejo

Salut James007

Le code réajusté, c'est plus fluide et plus simple à comprendre

Option Explicit

Sub fusion2()
Dim a, b(), i As Long, j As Long, n As Long, dico As Object, w
    With Sheets(3).Range("A1").CurrentRegion
        a = .Value
        ReDim b(1 To UBound(a, 1), 1 To 3)
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 1 To UBound(a, 1)
                If Not .exists(a(i, 1)) Then
                    n = n + 1
                    Set dico = CreateObject("Scripting.Dictionary")
                    dico.CompareMode = 1
                    For j = 1 To UBound(a, 2)
                        b(n, j) = a(i, j)
                        If j < 3 Then
                            If a(i, j) <> "" Then dico(a(i, j)) = Empty
                        End If
                    Next
                    .Item(a(i, 1)) = VBA.Array(n, dico)
                Else
                    w = .Item(a(i, 1))
                    If a(i, 2) <> "" And Not w(1).exists(a(i, 2)) Then
                        b(w(0), 2) = b(w(0), 2) & Chr(10) & a(i, 2)
                        w(1)(a(i, 2)) = Empty
                    Else
                        b(w(0), 2) = b(w(0), 2) & Chr(10)
                    End If
                    b(w(0), 1) = b(w(0), 1) & Chr(10)
                    b(w(0), 3) = b(w(0), 3) & Chr(10) & a(i, 3)
                End If
            Next
        End With
        Application.ScreenUpdating = False
        With .Offset(, .Columns.Count + 1)
            .CurrentRegion.Clear
            With .Resize(n, UBound(b, 2))
                .Value = b
                With .CurrentRegion
                    .Columns(1).Interior.ColorIndex = 19
                    .Font.Name = "calibri"
                    .Font.Size = 10
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .Borders(xlInsideHorizontal).Weight = xlThin
                    .Borders(xlInsideVertical).Weight = xlThin
                    .BorderAround Weight:=xlThin
                    .Columns.AutoFit
                    .Rows.AutoFit
                End With
            End With
            .Parent.Select
        End With
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Bonjour James 007

Bonjour Klin89

Tout d'abord merci d'avoir pris le temps de vous intéresser à mon problème.

Le problème structurel est que pour tout utilisateur d'Excel ... il faut impérativement banir les cellules fusionnées ...

Car elles sont l'ennemi juré par excellence ... et empêcheront ensuite les données d'être manipulées ...

S'il te faut absolument ce genre de tableau ... il existe un logiciel adapté : Word ...

En me baladant sur les forums, j'ai bien compris qu'il fallait éviter de fusionner des cellules, mais dans ce cas, c'est la dernière étape avant d'utiliser Word pour le publipostage, donc plus besoin de manipuler les données par la suite.

Le gros problème, c'est que je ne comprends rien à la solution que vous me proposez, je suppose que c'est de la programmation et je n'en ai jamais fait, même si ça a l'air passionnant, je pense au final que je me suis embarquée dans quelque chose de trop complexe

Je serais ravie si vous pouviez m'expliquer comment me servir de votre solution, si ce n'est pas trop compliqué bien sûr

Bonjour Annejo, le forum

J'ai recopié en Feuil1 les données comme illustrées sur ta capture d'image.

Clique sur le bouton en Feuil1, est-ce le résultat souhaité ?

Option Explicit

Sub fusion2()
Dim a, b(), i As Long, j As Long, n As Long, dico As Object, w
    With Sheets("Feuil1").Range("A1").CurrentRegion
        a = Application.Index(.Value, Evaluate("row(1:" & _
                                               .Rows.Count & ")"), Array(2, 6, 7))
        ReDim b(1 To UBound(a, 1), 1 To 3)
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 1 To UBound(a, 1)
                If Not .exists(a(i, 1)) Then
                    n = n + 1
                    Set dico = CreateObject("Scripting.Dictionary")
                    dico.CompareMode = 1
                    For j = 1 To UBound(a, 2)
                        b(n, j) = a(i, j)
                        If j < 3 Then
                            If a(i, j) <> "" Then dico(a(i, j)) = Empty
                        End If
                    Next
                    .Item(a(i, 1)) = VBA.Array(n, dico)
                Else
                    w = .Item(a(i, 1))
                    If a(i, 2) <> "" And Not w(1).exists(a(i, 2)) Then
                        b(w(0), 2) = b(w(0), 2) & Chr(10) & a(i, 2)
                        w(1)(a(i, 2)) = Empty
                    Else
                        b(w(0), 2) = b(w(0), 2) & Chr(10)
                    End If
                    b(w(0), 1) = b(w(0), 1) & Chr(10)
                    b(w(0), 3) = b(w(0), 3) & Chr(10) & a(i, 3)
                End If
            Next
        End With
        Application.ScreenUpdating = False
        With .Offset(, .Columns.Count + 1)
            .CurrentRegion.Clear
            With .Resize(n, UBound(b, 2))
                .Value = b
                With .CurrentRegion
                    .Columns(1).Offset(1).Resize(.Rows.Count - 1).Interior.ColorIndex = 19
                    .Rows(1).Interior.ColorIndex = 37
                    .Font.Name = "calibri"
                    .Font.Size = 10
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .Borders(xlInsideHorizontal).Weight = xlThin
                    .Borders(xlInsideVertical).Weight = xlThin
                    .BorderAround Weight:=xlThin
                    .Columns.AutoFit
                    .Rows.AutoFit
                End With
            End With
            .Parent.Select
        End With
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Bonsoir Annejo, le forum

En complément, cette 2 ème version :

Restitution en Feuil2.

Option Explicit

Sub fusion3()
Dim a, b(), i As Long, j As Long, n As Long, dico As Object, w, txt As String
    With Sheets("Feuil1").Range("A1").CurrentRegion
        a = .Value
        ReDim b(1 To UBound(a, 1), 1 To 7)
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 1 To UBound(a, 1)
                txt = Join$(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4), a(i, 5)))
                If Not .exists(txt) Then
                    n = n + 1
                    Set dico = CreateObject("Scripting.Dictionary")
                    dico.CompareMode = 1
                    For j = 1 To UBound(a, 2)
                        b(n, j) = a(i, j)
                        If j < 7 Then
                            If a(i, j) <> "" Then dico(a(i, j)) = Empty
                        End If
                    Next
                    .Item(txt) = VBA.Array(n, dico)
                Else
                    w = .Item(txt)
                    If a(i, 6) <> "" And Not w(1).exists(a(i, 6)) Then
                        b(w(0), 6) = b(w(0), 6) & Chr(10) & a(i, 6)
                        w(1)(a(i, 6)) = Empty
                    Else
                        b(w(0), 6) = b(w(0), 6) & Chr(10)
                    End If
                    For j = 1 To 5
                        b(w(0), j) = b(w(0), j) & Chr(10)
                    Next
                    b(w(0), 7) = b(w(0), 7) & Chr(10) & a(i, 7)
                End If
            Next
        End With
    End With
    Application.ScreenUpdating = False
    With Sheets("Feuil2").Cells(1)
        .CurrentRegion.Clear
        With .Resize(n, UBound(b, 2))
            .Value = b
            With .CurrentRegion
                .Columns(1).Offset(1).Resize(.Rows.Count - 1).Interior.ColorIndex = 19
                .Rows(1).Interior.ColorIndex = 37
                .Font.Name = "calibri"
                .Font.Size = 10
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Borders(xlInsideHorizontal).Weight = xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                .BorderAround Weight:=xlThin
                .Columns.ColumnWidth = 25
                .Columns.AutoFit
                .Rows.AutoFit
            End With
        End With
        .Parent.Select
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Bonjour Klin89,

Merci, mille fois merci, et quel beau cadeau d'anniversaire, c'est exactement le résultat que je voulais obtenir!

Maintenant, la grosse difficulté, c'est que je ne connais rien aux macros, mais alors rien du tout, et qu'il va falloir que j'apprivoise ton travail pour pouvoir m'en resservir.

En tout cas, merci à nouveau

Annejo