Remplissage automatique de cellules

Private Sub Worksheet_Activate()
Dim P As Range, t, i&, j%, k As Variant
With Sheets("B") 'à adapter
  Set P = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
End With
t = Range("A3:E" & Range("A" & Rows.Count).End(xlUp).Row + 1)
For i = 1 To UBound(t) Step 2
  For j = 2 To 5 'RAZ
    t(i, j) = "": t(i + 1, j) = ""
  Next
  k = Application.Match(t(i, 1), P, 0)
  If IsNumeric(k) Then
    t(i, 2) = P(k, 2) & " " & P(k, 3)
    t(i, 3) = P(k, 5)
    t(i, 4) = P(k, 7)
    t(i, 5) = P(k, 9)
    t(i + 1, 2) = P(k, 4)
    t(i + 1, 3) = P(k, 6)
    t(i + 1, 4) = P(k, 8)
    t(i + 1, 5) = P(k, 10)
  End If
Next
[A3].Resize(UBound(t), 5) = t
Range("B" & UBound(t) + 3 & ":E" & Rows.Count).ClearContents
End Sub

Private Sub Worksheet_Activate()
Dim P As Range, base, t(), i&, j%, k As Variant
With Sheets("B") 'à adapter
  Set P = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
End With
base = Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row + 1)
ReDim t(1 To UBound(base), 1 To 4) 'base 1
For i = 1 To UBound(t) Step 2
  k = Application.Match(base(i, 1), P, 0)
  If IsNumeric(k) Then
    t(i, 1) = P(k, 2) & " " & P(k, 3)
    t(i, 2) = P(k, 5)
    t(i, 3) = P(k, 7)
    t(i, 4) = P(k, 9)
    t(i + 1, 1) = P(k, 4)
    t(i + 1, 2) = P(k, 6)
    t(i + 1, 3) = P(k, 8)
    t(i + 1, 4) = P(k, 10)
  End If
Next
[B3].Resize(UBound(t), 4) = t
Range("B" & UBound(t) + 3 & ":E" & Rows.Count).ClearContents
End Sub

Private Sub Worksheet_Activate()
Dim base, t(), n&, i&
With Sheets("B") 'à adapter
  base = .Range("A2:J" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
ReDim t(1 To 2 * UBound(base), 1 To 5) 'base 1
n = -1
For i = 1 To UBound(base)
  n = n + 2
  t(n, 1) = base(i, 1)
  t(n, 2) = base(i, 2) & " " & base(i, 3)
  t(n, 3) = base(i, 5)
  t(n, 4) = base(i, 7)
  t(n, 5) = base(i, 9)
  t(n + 1, 2) = base(i, 4)
  t(n + 1, 3) = base(i, 6)
  t(n + 1, 4) = base(i, 8)
  t(n + 1, 5) = base(i, 10)
Next
If n > 1 Then [A3:E4].Copy [A5].Resize(n - 1, 5) 'pour les formats
[A3].Resize(n + 1, 5) = t
Range("A" & n + 4 & ":E" & Rows.Count).Delete xlUp
End Sub