Regroupement de données de 2 tableaux

Sub Regrouper()
Dim Fact, Livre, dicFact, dicLivre, Res, ref, fac
Dim i&, n&, k&

   Application.ScreenUpdating = False
   With Sheets("feuil1")
      i = .Cells(.Rows.Count, "f").End(xlUp).Row
      Livre = .Range("f5:g" & i).Value
      i = .Cells(.Rows.Count, "b").End(xlUp).Row
      Fact = .Range("b5:d" & i).Value
      Set dicLivre = CreateObject("scripting.dictionary")
      For i = 1 To UBound(Livre)
         dicLivre(CStr(Livre(i, 1))) = dicLivre(CStr(Livre(i, 1))) + Livre(i, 2)
      Next i
    
      ReDim Res(1 To dicLivre.Count * UBound(Fact), 1 To 4)
      n = 0
      For Each ref In dicLivre.keys
         Set dicFact = CreateObject("scripting.dictionary")
         For k = 1 To UBound(Fact)
            If CStr(Fact(k, 1)) = ref Then
               dicFact(Fact(k, 2)) = dicFact(Fact(k, 2)) + Fact(k, 3)
            End If
         Next k
        n = n + 1
        Res(n, 1) = CLng(ref)
         Res(n, 2) = dicLivre(ref)
         n = n - 1
         For Each fac In dicFact
            n = n + 1
            Res(n, 3) = fac
            Res(n, 4) = dicFact(fac)
         Next fac
      Next ref
    
      .Range("i5:L" & .Rows.Count).Clear
      .Range("i5").Resize(n, 4) = Res
      .Range("i5").Resize(n, 4).Borders.LineStyle = xlContinuous
      .Range("i5").Offset(, 2).Resize(n, 2).Font.Color = RGB(255, 0, 0)
   End With
End Sub

Sub PointOuPasPoint()
Dim i&,j&
With ActiveSheet
    .Range("A1:A1600") = [PI()]
    i = .Cells(Rows.Count, 1).End(xlUp).Row 'sans le point
    j = .Cells(.Rows.Count, 1).End(xlUp).Row 'avec le point
End With
MsgBox i & Space(3) & j
End Sub

Sub PointOuPasPoint()
Dim i&, j&, z&
z = Feuil1.Rows.Count
With Sheets("Feuil1")
      j = .Cells(z, 1).End(3).Row   'sans le point
      i = .Cells(z, 1).End(3).Row   'le point, non merci
End With
MsgBox i & Space(1600 / 1600) & j
End Sub