Lu76Fer
XLDnaute Occasionnel
Bonjour,
Le traitement et la copie massive de données vers une zone sur une feuille Excel codé par affectation directe à chaque cellule n'est pas très performante. Une solution peut consister à passer par une zone tampon beaucoup plus rapide d'accès.
Il existe une façon très simple de copier un tableau à deux dimensions de variant vers une zone Excel et ce tableau peut faire office de zone tampon :
VB:
Sub ExCopyData()
Dim vals(2, 2) As Variant, val As Variant, cnt%, iRow%, iCol%, area As Range
For iRow = 0 To 2 'Affectation de valeurs incrémentées dans le tableau
For iCol = 0 To 2
cnt = cnt + 1: vals(iRow, iCol) = cnt
Next iCol
Next iRow
Set area = [A1:C3]
area = vals 'Copie du tableau vers la grille
' Et inversement ...
Set area = [A4:C6]
'Remarque : il faut un Variant NON défini comme tableau
val = area 'Copie de la grille vers un tableau dynamique
End Sub
Maintenant, voici une façon d'implémenter une fonction qui permet la copie de ligne de donnée vers la grille utilisant une zone tampon :
VB:
Const MAX_ROWBLK = 10000
'Copie des lignes de données data() vers une zone rgRow en passant par une zone tampon de MAX_ROWBLK lignes.
'Réinit : en lançant la procédure sans données data() cela vide le buffer et réinitialise les données
Sub CopyDataBlockInSheet(ByRef rgRow As Range, ParamArray data() As Variant)
Static idx%, arData As Variant
Dim tot%, cnt%, blkArea As Range
tot = UBound(data)
If tot = -1 Then 'Sans donnée, copie immédiate du bloc arData vers la feuille
If idx > 0 Then
Set blkArea = rgRow.Resize(idx): blkArea = arData
Set rgRow = rgRow.Offset(idx): idx = 0
End If
If Not (IsEmpty(arData)) Then Erase arData 'Réinit
Else 'Remplir le bloc de données
If idx = MAX_ROWBLK Then Set blkArea = rgRow.Resize(idx): blkArea = arData: _
Set rgRow = rgRow.Offset(idx): idx = 0 'Copie arData vers la feuille
On Error GoTo InitBloc 'Si erreur allouer l'espace pr arData
CopyData:
For cnt = 0 To tot
arData(idx, cnt) = data(cnt)
Next cnt
idx = idx + 1
End If
Exit Sub
InitBloc:
ReDim arData(MAX_ROWBLK, tot): GoTo CopyData
End Sub
Il n'y a plus qu'à mettre en pratique avec 2 tests, Test1 avec une copie directe de 100 000 lignes vers une feuille nommée sous VBE, S_Demo, et Test2 utilisant la fonction ci-dessus. Ajouter à cela une fonction pour chronométrer la durée d'exécution de chaque test :
VB:
#If VBA7 Then
Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
#Else
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
#End If
Private StartTime&
'Lance le chrono StartTime
Sub StartTimer()
StartTime = GetTickCount()
End Sub
'Stop le chrono StartTime & Renvoie le temps écoulé du chrono
Function StopTimer() As Long
StopTimer = GetTickCount() - StartTime
StartTime = 0
End Function
Sub Test1() 'Temps de traitement = 20 826 ms
Dim lRow&, iCol%, cel As Range, tim&, av%
ClearSheet
Set cel = S_Demo.Cells(1, 1) '(100001, 1)
StartTimer
For lRow = 1 To 100000
For iCol = 0 To 9
cel.Offset(0, iCol) = lRow & "_" & iCol + 1
Next iCol
If lRow Mod 10000 = 0 Then av = av + 10: If av = 100 Then Debug.Print "# 100%" Else Debug.Print av & "% ";
Set cel = cel.Offset(1): DoEvents
Next lRow
tim = StopTimer
Debug.Print "Temps de traitement = " & Format(tim, "# ##0") & " ms"
End Sub
Sub Test2() 'Temps de traitement = 1 966 ms
Dim lRow&, rgRow As Range, tim&, av%
ClearSheet
Set rgRow = S_Demo.Cells(1, 1).Resize(, 10)
StartTimer
For lRow = 1 To 100000
CopyDataBlockInSheet rgRow, lRow & "_" & 1, lRow & "_" & 2, lRow & "_" & 3, lRow & "_" & 4, lRow & "_" & 5, _
lRow & "_" & 6, lRow & "_" & 7, lRow & "_" & 8, lRow & "_" & 9, lRow & "_" & 10
If lRow Mod 10000 = 0 Then av = av + 10: If av = 100 Then Debug.Print "# 100%" Else Debug.Print av & "% ";
Next lRow
CopyDataBlockInSheet rgRow 'Copie des données restantes et Réinit.
tim = StopTimer
Debug.Print "Temps de traitement = " & Format(tim, "# ##0") & " ms"
End Sub
Sub ClearSheet()
S_Demo.Cells.ClearContents: Set rg = ActiveSheet.UsedRange
End Sub
En lançant successivement le Test1 et le Test2 depuis VBE on peut constater des performances très inégales : Test2 est environ 10 fois plus rapide que Test1 sur une version Excel 2016 64 bits.
Dans un autre projet, j'ai pu constater que le gain en performance peut devenir Gargentuesque, et on n'a pas souvent l'occasion de placer le mot (...) Gargentuesque; lorsque mon fichier grossit avec le volume de donnée la copie devient si lente que j'estime qu'avec l'utilisation d'un tampon cela permet d'être #100 fois plus rapide !
Il est possible d'intégrer aux données des formules utilisateurs car "Excel" reconnait automatiquement si la donnée est une Formule Utilisateur. Pour cela, il suffit de définir votre formule directement dans la grille puis de se positionner sur la cellule avec votre formule.
Puis dans VBE lancer par exemple la ligne d'instruction suivante : Debug.print ActiveCell.FormulaR1C1
Dernier test avec une formule :
VB:
Sub Test3() 'Temps de traitement = 3 760 ms
Const FORM = "=SUM(RC[-3]:RC[-1])"
Dim lRow&, rgRow As Range, tim&, av%
ClearSheet
'S_Demo.EnableCalculation = False 'Sans effet notable sur le temps de traitement
Set rgRow = S_Demo.Cells(1, 1).Resize(, 11)
StartTimer
For lRow = 1 To 100000
CopyDataBlockInSheet rgRow, lRow * 10, lRow * 10 + 1, lRow * 10 + 2, lRow * 10 + 3, lRow * 10 + 4, _
lRow * 10 + 5, lRow * 10 + 6, lRow * 10 + 7, lRow * 10 + 8, lRow * 10 + 9, FORM
If lRow Mod 10000 = 0 Then av = av + 10: If av = 100 Then Debug.Print "# 100%" Else Debug.Print av & "% ";
Next lRow
CopyDataBlockInSheet rgRow 'Copie des données restantes et Réinit.
tim = StopTimer
Debug.Print "Temps de traitement = " & Format(tim, "# ##0") & " ms"
'S_Demo.EnableCalculation = True
End Sub