Soustraction sous VBA d'une base importante Fermé

Question

Bonjour,

Je souhaiterais faire une soustraction d'une colonne D - colonne E et afficher le resultat sur la F. Et ce, tant qu'il y a des nombres sur la colonne D ou E.

Vous m'avez déjà aidé pour trouver le code que je vais saisir ci-dessous et je vous en remercie.

En revanche, j'ai remarqué que sur un fichier de plusieurs dizaines de milliers de lignes, la macro prenait 5 à 10 minutes. Ce qui m'étonne car via excel la soustraction est quasiment instantanée.

Sachant que je dois utiliser VBA, auriez vous une idée pour modifier le code pour que ca prenne moins de temps. au pire 30 secondes à 1 munute, mais au delà cela n'est plus efficace.

En vous remerciant par avance

Dim lg, i As Long
With ActiveSheet.Range("D1:E65000")
lg = .Row + .Rows.Count - 1
End With
For i = lg To 2 Step -1
If Cells(i, "D") <> "" And Cells(i, "E") <> "" Then
Cells(i, "F").FormulaR1C1 = "=RC[-2]-RC[-1]"
End If
Next i

Excel 2003

eriiic · Answer

Bonjour,  

Ca sert à quoi de poser la question si tu ne testes pas toutes les réponses ?   
Voir ici :  
https://forums.commentcamarche.net/forum/affich-26873406-appliquer-une-formule-jusqu-a-la-derniere-ligne-des-variables#10   
Ce n'est pas parce qu'il n'y a pas de boucle et une seule ligne que c''est incomplet. C'est juste plus rapide parce qu'il n'y a pas de boucle justement.   
Rien à rajouter, éventuellement
Application.screenupdating=false devant et
Application.screenupdating=true après.

eric  
Jamais tu ne répondras à un mp non sollicité...  
Bon, ça c'est fait.

yanounou · Answer

Bonsoir,

Désolé Eric. Il est vrai que comme la formule fonctionnait je n'ai pas testé la votre. Mais quand j'ai voulu la testé sur une base plus grande cela n'alalit plus (lenteur).

Voici un code où j'ai utilisé votre code. Et cela marche malgré une longueur mais qui ne vient pas de votre code mais des remplacement des "." par des ",". 

En revanche je ne sais plus pourquoi dorénavant le tableau croisé dynamique ne veut plus fonctionner. Pour information en plus de vouloir faire une soustraction dans cette base, je l'utilise par la suite pour créer un VBA.

Columns("D:E").Select
    Selection.Replace What:=".", Replacement:=",", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Columns("F:F").Select
    Selection.Insert Shift:=xlToRight
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "Montant solde"
    [F2].Resize(Application.Min(Cells(Rows.Count, "D").End(xlUp).Row - 1, Cells(Rows.Count, "E").End(xlUp).Row - 1), 1).FormulaLocal = "=D2-E2"
    Range("A1:R65000").Select
    ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
        "A1:R65000").CreatePivotTable TableDestination:="", TableName:= _
        "Tableau croisé dynamique1", DefaultVersion:=xlPivotTableVersion10
    ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)
    ActiveSheet.PivotTables("Tableau croisé dynamique1").AddFields RowFields:= _
        Array("CGR A", "Poste", "Libellé réduit du compte", "Libellé", "Libellé écriture", _
        "Date Compt", "Pièce", "Ets")
    With ActiveSheet.PivotTables("Tableau croisé dynamique1").PivotFields( _
        "Montant solde")
        .Orientation = xlDataField
        .NumberFormat = "# ##0"
    End With


sauriez vous pourquoi à la premiere etape du TCD (ADD Field), VBA plante ?

En vous remerciant pour votre aide.

yanounou · Answer

Eric, j'ai placé l'application.screenupdating. Je pense que c'est peut etre un peu mieux mais ca reste tout de meme tres tres tres long. D'après toi le code que je place ne contient pas d'erreur ?

Sinon j'ai toujours l'erreur dès l'instruction add.fields row field ... je te place le code ci-dessous.

Sub CMCGR()
'
' CMCGR Macro
' Macro enregistrée le 10/01/2013 par b276573
'

'
Application.ScreenUpdating = False
Columns("D:E").Select
Selection.Replace What:=".", Replacement:=",", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Columns("F:F").Select
Selection.Insert Shift:=xlToRight
Range("F1").Select
ActiveCell.FormulaR1C1 = "Montant solde"
Dim lg, i As Long
With ActiveSheet.Range("D1:E65000")
lg = .Row + .Rows.Count - 1
End With
For i = lg To 2 Step -1
If Cells(i, "D") <> "" And Cells(i, "E") <> "" Then
Cells(i, "F").FormulaR1C1 = "=RC[-2]-RC[-1]"
End If
Next i
Application.ScreenUpdating = True
Range("A1:R65000").Select
Application.CutCopyMode = False
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
"A1:R65000").CreatePivotTable TableDestination:="", TableName:= _
"Tableau croisé dynamique1", DefaultVersion:=xlPivotTableVersion10
ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)
ActiveSheet.Cells(3, 1).Select
ActiveSheet.PivotTables("Tableau croisé dynamique1").AddFields RowFields:= _
Array("CGR A", "Poste", "Libellé réduit du compte", "Libellé", "Libellé écriture", _
"Date Compt", "Pièce", "Ets")
With ActiveSheet.PivotTables("Tableau croisé dynamique1").PivotFields( _
"Montant solde")
.Orientation = xlDataField
.NumberFormat = "# ##0"

Cordialement

michel_m · Answer

bonjour Voici pour la partie longue à tester Le code tcd n'aura pas d'influence sur la durée par rapport à un autre code à part la ligne Range ("A1:R65000") qui aurait méritée d'^tre réduite à la dernière ligne utilisée (cf variable derlig) si tu veux gagner du temps Sub soustraire() Dim Derlig As Long, T_in(), T_out(), cptr As Long Dim Start As Single Start = Timer Application.ScreenUpdating = False Derlig = Cells.Find("*", , , , , xlPrevious).Row T_in = Application.Transpose(Range("D2:E" & Derlig).Value) T_out = Application.Transpose(Range("F2:F" & Derlig).Value) For cptr = 1 To UBound(T_in) If T_in(cptr, 1) <> "" Then If T_in(cptr, 2) <> "" Then T_out(cptr) = T_in(cptr, 1) - T_in(cptr, 2) Next Range("F2:F" & Derlig) = Application.Transpose(T_out) Application.ScreenUpdating = True MsgBox "durée : " & Timer - Start & " .sec"

Sub soustraire()  
Dim Derlig As Long, T_in(), T_out(), cptr As Long  
Dim Start As Single  

Start = Timer  
Application.ScreenUpdating = False  
Derlig = Cells.Find("*", , , , , xlPrevious).Row  
T_in = Application.Transpose(Range("D2:E" & Derlig).Value)  
T_out = Application.Transpose(Range("F2:F" & Derlig).Value)  

For cptr = 1 To UBound(T_in)  
     If T_in(cptr, 1) <> "" Then  
          If T_in(cptr, 2) <> "" Then T_out(cptr) = T_in(cptr, 1) - T_in(cptr, 2)  
Next  

Range("F2:F" & Derlig) = Application.Transpose(T_out)  
Application.ScreenUpdating = True  
MsgBox "durée : " & Timer - Start & " .sec"  
End If
   
Sans ton classeur je n'ai pu tester la macro  

Excuses moi, Eric, je n'avais pas vu qu'il y avait déjà des réponses !!! :-/
   
 Michel

michel_m · Answer

Bonjour

Je t'ai écris que ..."Sans ton classeur je n'ai pu tester la macro "... j'ai aussi 2007

Donc un extrait 3000 ou 4000 lignes de ton classeur serait le bienvenu

J'ai proposé la partie "chronophage" et non la partie TCD, cette dernière une fois réduit la surface par la recherche de la dernière ligne, n'avait que peu d'incidence sur la rapidité de la procédure

pour joindre une pièce
mettre le classeur sans données confidentielles en pièce jointe sur
https://www.cjoint.com/ 
puis copier l'adresse du lien et la coller dans le message de réponse

yanounou · Answer

Bonjour Eric et Michel en cette journée enneignée,

Voici le lien pour un fichier exemple ( j'ai pris une base très limitée en ligne) : http://cjoint.com/?CAtmzYZLSLI

et voici le code que j'utilise actuellement sur vba 2007 et qui plante au niveau de la soustraction (à savoir que sur vba 2003 cela fonctionnait) :

Application.ScreenUpdating = False
Columns("D:E").Select
Selection.Replace What:=".", Replacement:=",", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Columns("F:F").Select
Selection.Insert Shift:=xlToRight
Range("F1").Select
ActiveCell.FormulaR1C1 = "Montant solde"
Dim Derlig As Long, T_in(), T_out(), cptr As Long
Derlig = Cells.Find("*", , , , , xlPrevious).Row
T_in = Application.Transpose(Range("D2:E" & Derlig).Value)
T_out = Application.Transpose(Range("F2:F" & Derlig).Value)

For cptr = 1 To UBound(T_in)
If T_in(cptr, 1) <> "" Then T_out(cptr) = T_in(cptr, 1) - T_in(cptr, 2)
If T_in(cptr, 2) <> "" Then T_out(cptr) = T_in(cptr, 1) - T_in(cptr, 2)
End If
Range("F2:F" & Derlig) = Application.Transpose(T_out)
Next cptr
Application.ScreenUpdating = True
Range("A1:R65000").Select
Application.CutCopyMode = False
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
"A1:R65000").CreatePivotTable TableDestination:="", TableName:= _
"Tableau croisé dynamique1", DefaultVersion:=xlPivotTableVersion10
ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)
ActiveSheet.Cells(3, 1).Select
ActiveSheet.PivotTables("Tableau croisé dynamique1").AddFields RowFields:= _
Array("CGR A", "Poste", "Libellé réduit du compte", "Libellé", "Libellé écriture", _
"Date Compt", "Pièce", "Ets")
With ActiveSheet.PivotTables("Tableau croisé dynamique1").PivotFields( _
"Montant solde")
.Orientation = xlDataField
.NumberFormat = "#,##0"
End With

Cordialement

Soustraction sous VBA d'une base importante

6 réponses

Discussions similaires