Compresser d'images dans Excel par VBA

Bonjour,

J'ai pompé une macro en VBA Excel pour gérer une base / Collection de BD.
Pour chaque album que je rentre dans ma feuille à l'aide d'un formulaire, j'affiche une image de la couverture et je l'insère sur la ligne.
Par contre mon fichier devient assez gros puisque les images se retrouvent embarquées dans la feuille. Elles sont bien entendu réduites en taille d'affichage, mais ne sont pas compressées. Donc pour un peu moins de 600 albums de BD, ma base fait déjà plus de 27 Mo et répond assez lentement aux sollicitations (ouverture, enregistrement, tris ...)

Est ce qu'il y a un moyen pour compresser ces images ?

Voici le bout du "code" lorsque je clique sur OK dans mon formulaire :

Private Sub OK_Click()
If Trim(TextTitre) = "" Then
MsgBox "Entrez le titre de la BD ou du Manga", vbOKOnly, "Attention"
End If
Range("B1").End(xlDown).Select
Selection.Offset(1, -1).Select
On Error Resume Next
ActiveSheet.Pictures.Insert(Chemin & TextSérie & " - " & TextTome & " - " & TextTitre & ".jpg").Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 70
With ActiveCell
.RowHeight = 72
.EntireRow.VerticalAlignment = xlCenter
.Offset(0, 1).Value = TextSérie
.Offset(0, 2).Value = TextTome
.Offset(0, 3).Value = TextTitre
If Trim(TextCollec) <> "" Then .Offset(0, 4).Value = TextCollec
If Trim(ChoixEdit) <> "" Then .Offset(0, 5).Value = ChoixEdit
If Trim(TextParution) <> "" Then .Offset(0, 6).Value = TextParution
If Trim(TextScénar) <> "" Then .Offset(0, 7).Value = TextScénar
If Trim(TextDessin) <> "" Then .Offset(0, 8).Value = TextDessin
If Trim(TextCouleurs) <> "" Then .Offset(0, 9).Value = TextCouleurs

End With
Unload FrmBD
End Sub

La partie qui concerne le chargement de la couverture est en gras.

Merci à tous et bonne journée.