[XL-2010] Problème de concatenation

Bonjour,

Une solution possible avec ce code :
Code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
Option Explicit
 
Sub Concatenation()
 
Dim CtrI As Long
Dim NbLignesACote As Long
Dim DerniereLigneTableau1 As Long
Dim LigneEnCoursFeuille2 As Long
 
Dim ContenuLignes As String
Dim CelluleDACote As Range
Dim AireDACote As Range
Dim AireColonne1 As Range
Dim CelluleColonne1 As Range
 
Dim ShSource As Worksheet
Dim ShCible As Worksheet
 
  Set ShSource = Sheets("Feuil1")
  Set ShCible = Sheets("Feuil2")
  ShCible.Cells.Clear
 
  DerniereLigneTableau1 = ShSource.Cells(ShSource.Rows.Count, 1).End(xlUp).Row
 
  Set AireColonne1 = Range(ShSource.Cells(2, 1), ShSource.Cells(DerniereLigneTableau1, 1))
 
  LigneEnCoursFeuille2 = 2
  For Each CelluleColonne1 In AireColonne1
      If CelluleColonne1 <> "" Then
        ContenuLignes = ""
        NbLignesACote = CelluleColonne1.Offset(1, 0).Row - CelluleColonne1.Row
        CtrI = 0
        Set AireDACote = Range(ShSource.Cells(CelluleColonne1.Row, 2), ShSource.Cells(CelluleColonne1.Row + NbLignesACote - 1, 2))
        For Each CelluleDACote In AireDACote
         CtrI = CtrI + 1
         If CtrI < NbLignesACote Then
          ContenuLignes = ContenuLignes & CelluleDACote & Chr(10)
         Else
          ContenuLignes = ContenuLignes & CelluleDACote
         End If
 
        Next CelluleDACote
        Set AireDACote = Nothing
        ShCible.Cells(LigneEnCoursFeuille2, 1) = CelluleColonne1
        ShCible.Cells(LigneEnCoursFeuille2, 2) = ContenuLignes
        LigneEnCoursFeuille2 = LigneEnCoursFeuille2 + 1
     End If
 
  Next CelluleColonne1
 
  With ShCible.Cells
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlTop
        .EntireColumn.AutoFit
        .WrapText = True
  End With
  ShCible.Cells.Columns(1).HorizontalAlignment = xlCenter
  ShCible.Cells.Columns(2).HorizontalAlignment = xlLeft
 
  RetablirLesBorduresFeuille2 ShCible
 
  Set AireColonne1 = Nothing
  Set ShSource = Nothing
  Set ShCible = Nothing
 
End Sub
 
 
Sub RetablirLesBorduresFeuille2(FeuilleCible As Worksheet)
 
Dim PremiereLigne As Long
Dim NbLignes As Long
Dim TypeDeTrait As Long
Dim AireBordure As Range
 
        TypeDeTrait = 2  ' Trait très fin : xlHairline 1, moyen : xlMedium -4138, épais : xlThick 4 , fin : xlThin 2
        PremiereLigne = 2
        NbLignes = FeuilleCible.Cells(FeuilleCible.Rows.Count, 1).End(xlUp).Row
 
        Set AireBordure = Range(FeuilleCible.Cells(2, 1), FeuilleCible.Cells(NbLignes, 2))
 
        With AireBordure
                     .Borders(xlEdgeTop).Weight = TypeDeTrait
                     .Borders(xlEdgeBottom).Weight = TypeDeTrait
                     .Borders(xlEdgeLeft).Weight = TypeDeTrait
                     .Borders(xlEdgeRight).Weight = TypeDeTrait
                     .Borders(xlInsideVertical).Weight = TypeDeTrait
                     .Borders(xlInsideHorizontal).Weight = TypeDeTrait
       End With
 
       Set AireBordure = Nothing
 
End Sub
Pour le fonctionnement, on doit définir la feuille source et la feuille cible ainsi que la ligne de début de la feuille source.

La deuxième macro reconstitue les bordures.

Cordialement.