récuperer les informations de plusieurs lignes sur une seule

[COLOR="DarkSlateGray"][B]Sub toto()
Dim n&, i&, j&, k&, shn, shi
Dim oTtr, lDat, oDat, oColl As New Collection
[COLOR="SeaGreen"]'  "NOM" est la plage nommée définie par _
   =DECALER('suivi patients'!$A$14;1;0;MAX(('suivi patients'!$A$15:$A$1015<>"")*LIGNE('suivi patients'!$A$1:$A$1001));1)[/COLOR]
   oTtr = Range("NOM").Offset(-1, 0).Resize(1, 7).Value
   oDat = Range("NOM").Resize(, 7).Value
   ReDim lDat(1 To 1, 1 To UBound(oDat, 2))
   For i = 1 To UBound(oDat, 1)
      shn = oDat(i, 1)
      If Not IsEmpty(shn) Then
         n = 10
         On Error GoTo E
         shi = Sheets(shn).Name
         On Error GoTo D
         oColl.Add shi, CStr(shn)
         On Error GoTo 0
         For j = 1 To UBound(oDat, 1)
            If oDat(j, 1) = shn Then
               n = n + 1
               For k = 1 To UBound(oDat, 2)
                  lDat(1, k) = oDat(j, k)
               Next k
               Sheets(CStr(shn)).Rows(n).Resize(1, UBound(lDat, 2)) = lDat
            End If
         Next j
A:    End If
   Next i
Exit Sub
D: Resume A
E: Application.DisplayAlerts = False
   Worksheets.Add
   ActiveSheet.Name = CStr(shn)
   Application.DisplayAlerts = True
   ActiveSheet.Cells(n, 1).Resize(1, UBound(lDat, 1)) = oTtr
   Resume
End Sub[/B][/COLOR]