2
\$\begingroup\$

Is there a way to make this code run faster? I have over 6000 pictures in .jpg optimized to a maximum of 40 kB. It starts quickly but after like 2000 pictures it runs way slower. The final .xlsm file is about 380 MB.

I'm using Excel 2016 with Windows 10 on a big server with 16 processors and 80 GiB RAM.

Sub Button5_Click()
With Excel.Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.DisplayStatusBar = False
.EnableEvents = False
End With
With Worksheets
DisplayPageBreaks = False
End With
ChargeTrombinoscope
With Excel.Application
.EnableEvents = True
.DisplayStatusBar = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
With Worksheets
DisplayPageBreaks = True
End With
''''CheckImageName
End Sub

Sub ChargeTrombinoscope()
Dim Chemin As String, Fichier As String
Dim nom, nom As String
Dim splitArr() As String
Dim Ligne As Integer
Dim Largeur As Integer
Dim Hauteur As Integer
Dim h As Long, Rapport As Single
Const hDefaut = 97

Worksheets("Pix").Activate

  'Définit le répertoire contenant les fichiers
Chemin = "C:\IMAGES\"

  'Boucle sur tous les fichiers du répertoire (photos).
Ligne = 3
Columns("K:K").ColumnWidth = 40  ' défini la largeur de la colonne
Columns("H:H").ClearContents
Columns("I:I").ClearContents
For Each Sh In ActiveSheet.Shapes
   If Sh.Type = msoPicture Then 'msoPicture Then
      Sh.Delete
   End If
Next Sh


Fichier = Dir(Chemin & "*")
Do While Len(Fichier) > 0
  'Extraction nom
  splitArr = Split(Fichier, ".")
  nom = splitArr(0)
  Range("H" & Ligne).Value = CStr(nom)
  Range("H" & Ligne).NumberFormat = "@"
  Range("I" & Ligne) = "a" & Range("H" & Ligne)     ''' pour corriger le bogue des noms numériques
  'insertion de la photo dans la colonne K
  Range("K" & Ligne).Select
''  Largeur = Range("K" & Ligne).Width
''  Hauteur = Range("K" & Ligne).Height

 ActiveCell.RowHeight = 99  ' ajuste la hauteur de la ligne : 1 point = 0,035 cm

h = hDefaut
h = h - 4

  ActiveSheet.Shapes.AddPicture(Chemin & Fichier, False, True, ActiveCell.Left, ActiveCell.Top, Largeur, Hauteur).Select

With Selection.ShapeRange
    Rapport = h / Selection.Height
    AjusterImage Selection, Rapport
   .Name = Range("I" & Ligne)
End With


  'Fichier suivant
  Fichier = Dir()
  Ligne = Ligne + 1
Loop
  Range("H3").Select

With Worksheets("Pix")
   DerLig = .Range("H" & Rows.Count).End(xlUp).Row
   ActiveWorkbook.Names("PicTable").Delete
   ActiveWorkbook.Names.Add Name:="PicTable", RefersTo:="=Pix!$H$2:$H$" & DerLig
End With

End Sub

Function AjusterImage(Imag As Object, Rapport As Single)
Dim Largeur As Single
Dim Hauteur As Single

Largeur = Imag.Width
Hauteur = Imag.Height
Largeur = Largeur * Rapport
Hauteur = Hauteur * Rapport
Imag.Width = Largeur
Imag.Height = Hauteur
End Function
\$\endgroup\$
  • 1
    \$\begingroup\$ how does it run with resizing disabled? If that makes it fast, you could prepare the catalog images with ImageMagick or another tool that is optimized for bulk image handling. If it's still too slow, try removing the call to AddPicture(). If that solves it, it may simply be that Excel is the wrong tool for this job. \$\endgroup\$ – Oh My Goodness Jan 27 at 4:50
1
\$\begingroup\$

Avoid Selecting of Activating Object unless absolutely necessary Excel VBA Introduction Part 5 - Selecting Cells (Range, Cells, Activecell, End, Offset).

Writing an array of values to a worksheet is much faster than writing the values individually.

The Worksheet.Pictures method returns a collection of pictures on the worksheet.
You can get a subset of pictures by passing an Array of Indices as a parameter to the Worksheet.Pictures method:

 ActiveSheet.Pictures(Array(1,2,30))

Or an Array of names:

 ActiveSheet.Pictures(Array("Picture 1","Picture 2","Picture 3"))

You can also work on the whole collection or subset at once:

 ActiveSheet.Pictures.Delete

Formatting a range of cells is much faster than formatting each cell in a range.

Columns("H:I").ClearContents
Columns("H").NumberFormat = "@"

Short compact code is much easier to read.

Which is easier to read?


h = hDefaut
h = h - 4

Or

 h = hDefaut - 4

Largeur = Imag.Width
Hauteur = Imag.Height
Largeur = Largeur * Rapport
Hauteur = Hauteur * Rapport
Imag.Width = Largeur
Imag.Height = Hauteur

Or

Largeur = Imag.Width * Rapport
Hauteur = Imag.Height * Rapport

With Worksheets("Pix")
   DerLig = .Range("H" & Rows.Count).End(xlUp).Row
   ActiveWorkbook.Names("PicTable").Delete
   ActiveWorkbook.Names.Add Name:="PicTable", RefersTo:="=Pix!$H$2:$H$" & DerLig
End With

The code above can be simplified:

With Worksheets("Pix")
   .Range("H2",.Range("H" & Rows.Count).End(xlUp)).Name = "PicTable"
End With

MS Access is better suited for this type of thing. I personally would create a webpage. Whether I used Excel or a webpage I would create a paginator and avoid embedding the images.

I refactored your code here: Making a catalog of pictures.xlsm. Note: I didn't make the Rapport size adjustments but it should be easy enough for you to implement it.

\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.