XLSM : Copie massive de ligne de données vers la grille

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

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
 
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
Bonjour, Good Job. Tu un fichier exemple stp avec ton code ? ça serait plus simple 🙂 merci
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD
Retour