comment insérer valeurs de plusieurs cellules dans unique cellule

Sub Toto()
   Dim rg1 As Range, rg2 As Range
   Dim ar1(1 To 8, 1 To 8), ar2
   Dim i As Integer, j As Integer

   Set rg1 = Sheets("Feuil5").Range("B14")   'matrice
   Set rg2 = Sheets("Atelier 1").Range("A15:I63")   'tableau
   ar2 = rg2.Value
   For i = 2 To UBound(ar2, 1) - 1
      If ar2(i, 1) <> "" Then
      j = Application.Match(ar2(i, 8), Array("A", "B", "C", "D", "E", "F", "G", "H"))
      If ar1(j, ar2(i, 9)) = "" Then
         ar1(j, ar2(i, 9)) = ar2(i, 1)
      Else
         ar1(j, ar2(i, 9)) = ar1(j, ar2(i, 9)) & vbLf & ar2(i, 1)
      End If
      End If
   Next i
   rg1.Resize(8, 8) = ar1
End Sub