What I'm trying to do here is to open an Excel file and then search for and store the data I need (i.e if there is a reference then I copy 2 columns). Afterwards, I paste or write that data into a Word table that already exists in my template.
Thus, here is my question: Is there a way to make run faster? It runs in about 21 seconds, and I would like it to be faster because I have plenty of macros to run and if each one runs about 20 seconds then my users won't be satisfied.
Here is the code:
Sub fournitureExcel(trigram As String, nbTable As Long, folderPath As String)
Dim filename As String, dataRange As String, dataC As New Collection
Dim refRow As Long, refColumn As Long, desigColumn As Long 'la ligne de la trigramme recherche
Dim j As Long, c As Long
With ActiveDocument
.Application.ScreenUpdating = False
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If err Then
Set xlApp = CreateObject("Excel.Application")
End If
On Error GoTo 0
filename = "DE_Nom_art_" & trigram & ".xlsx"
Set xlBook = xlApp.workbooks.Open(folderPath & filename)
xlApp.Visible = False 'does not open the file, read only => faster to get the info
With xlBook.sheets(1)
' searching for the Reference
Set rg = .Cells.Find(what:="Référence")
refRow = .Range(rg.Address).Row: refColumn = .Range(rg.Address).Column
Set desigAdrs = .Cells.Find(what:="Désignation")
'numero de colone Designation
desigColumn = .Range(desigAdrs.Address).Column: dataRange = "G" & (refRow + 2) & ":I" & 10000
'stock excel data into a collection
For Each cell In .Range(dataRange)
If cell.Column = refColumn Then
If Not IsEmpty(cell) Then ' checking if reference exists or not
'designation & quantite
dataC.Add .Cells(cell.Row, refColumn - 2).Value: dataC.Add .Cells(cell.Row, refColumn - 1).Value
End If
End If
Next cell
xlBook.Close SaveChanges:=False ' pour ne pas sauvegarder le document
Set src = Nothing
Set xlApp = Nothing
Set xlBook = Nothing
End With
'ajoute des lignes a la table fournitures i.e table nr3
.Tables(nbTable).Select
c = .Tables(nbTable).Range.Rows.Count
'c = .Tables(nbTable).Rows.Count
If c - (dataC.Count / 2) < 0 Then 'check if we need to add rows or not
With Selection
.InsertRowsBelow -(c - (dataC.Count / 2))
With .Shading
.Texture = wdTextureNone
.ForegroundPatternColor = wdColorAutomatic
.BackgroundPatternColor = -603914241
End With
.Font.ColorIndex = wdBlack
'ajout des bordures dans le tableau
With .Borders
.InsideLineStyle = wdLineStyleSingle
.OutsideLineStyle = wdLineStyleSingle
.InsideColorIndex = wdBlack
.OutsideColorIndex = wdBlack
End With
End With
Else
' do nothing
End If
j = 3 'indice apartir du quel on va commencer a lire les donnees de la collection car on skip les 2 premiers
'fill the table
For i = 2 To dataC.Count / 2
With .Tables(nbTable).Rows(i)
' la designation & la quantites
With .Cells(1).Range
.Text = dataC(j):
.ParagraphFormat.Alignment = wdAlignParagraphLeft 'aligne text to the left
End With
.Cells(2).Range.Text = dataC(j + 1)
With .Range
.Font.ColorIndex = wdBlack 'text color :black
.Font.Size = 9 ' Set String size = 9
' If the string begins with "Baie" then make it Bold
If Left(dataC(j), Len("Baie")) = "Baie" Then
.Bold = True
Else
.Bold = False
End If
End With
j = j + 2
End With
Next i
'ActiveDocument.Tables(3).Rows.Last.Cells.Delete 'on efface la derniere ligne
.Application.ScreenUpdating = True
End With
End Sub