Suite macro trop longue

Pour mieux comprendre mon précédent email (voir plus bas) vous trouverez en pièce jointe mon fihcier xls que j'ai bien réduit .

merci encore

(mon précédent email)

Bonjour,

Je débute ma première qui n'est pas finalisée à 100%. Car je suis déjà bloquée par la durée du traitement de ma macro (+ de 6 minutes). Pour résumer j'ai des remboursements (mutuelle) que je reçois en banque (onglet BDD). Ces remboursements pour lesquels je connais le nom la date et le montant doivent être comptabilisés de telle sorte à ce qu'ils soient bien affectés en fonction d'une clé de répartition que nous retrouvons dans l'onglet BDD puis en fonction de son poste budgétaire (en l'occurrence dans mon exemple concaténation des lignes DIR et IMPUT).

Le problème est que j'ai plus de 4000 lignes dans ma BDD (qui est déjà une base que j'ai réduite pour le test) et le temps de travail est de + de 6 minutes.

Quelqu'un pourrait -il m'aider ? je peux vous envoyer le fichier sur une messagerie perso (car pas envie d'avoir de problème)

Merci beaucoup.

bonjour,

voici une optimisation de ton code. ce code fait l'hypothèse que tous les matricules sont numériques et sont compris entre 0 et 10001.

Sub ipsaperso0713opt()
Dim totalmatricule(10000) As Single, indexmatricule(10000) As Long
Start = Timer

' ipsaperso0713 Macro
'

i = 2
While Cells(i, 1) <> ""
 Cells(i, "G") = Format(Cells(i, "C"), "0000") & "0000-21 VIRT IPSA " & Cells(i, "D") & " du " & Day(Cells(i, "A")) & " " & Month(Cells(i, "A")) & " de " & Cells(i, "F")
 'sumif par matricule
 totalmatricule(Cells(i, "C")) = totalmatricule(Cells(i, "C")) + Cells(i, "F")
' on retient le numéro de ligne de la première occurrence du matricule (pour la copie de G)
 if  indexmatricule(Cells(i, "C")) = 0 then indexmatricule(Cells(i, "C")) = i
 i = i + 1
Wend

With Sheets("BDD")
 .Range("J1") = "sommesi"
 .Range("K1") = "sommesicle"
 .Range("L1") = "arrondis2"
 .Range("M1") = "ana"
 .Range("N1") = "LIBELLE"
 j = 2
 While .Cells(j, "A") <> ""
  If totalmatricule(.Cells(j, "C")) = 0 Then
   Rows(j).Delete
  Else
   .Range("J" & j) = totalmatricule(.Cells(j, "C"))
   .Range("K" & j) = .Cells(j, "J") * .Cells(j, "I")
   .Range("L" & j) = Round(.Cells(j, "K"), 2)
   .Range("M" & j) = .Cells(j, "F") & .Cells(j, "G")
   .Range("N" & j) = Worksheets("SG").Cells(indexmatricule(.Cells(j, "C")), "G")
   j = j + 1
  End If
 Wend
End With
Application.ScreenUpdating = True

MsgBox "durée du traitement: " & Timer - Start & " secondes"

End Sub

Bonjour

A tester

Bonjour h2so4

Bonjour

Une version d'amateur (J'ai quand même le droit de chercher..)

Sub ipsaperso0713()

Start = Timer
' ipsaperso0713 Macro
'Selectionne la première cellule A1 va vers la dernière colonne non vide de la ligne A Descend d'une ligne vers le bas et une vers la droite.
' puis concatene
Sheets("SG").Select
Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
Selection.Offset(, 6).Select
Selection.FormulaR1C1 = _
"=CONCATENATE(TEXT(RC[-4],""0000""),""0000-21 "",""VIRT IPSA "",RC[-3],"" du "",DAY(RC[-6]),"" "",MONTH(RC[-6]),"" de "",RC[-1])"

Application.ScreenUpdating = False
' copier collage valeur (de la concatenation)
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("G2").Select

' appliquer la formule pour chacune des 4colonnes crées.
Sheets("BDD").Select
Range("J1").Select
ActiveCell.FormulaR1C1 = "sommesi"
Range("K1").Select
ActiveCell.FormulaR1C1 = "sommesicle"
Range("L1").Select
ActiveCell.FormulaR1C1 = "arrondis2"
Range("M1").Select
ActiveCell.FormulaR1C1 = "ana"
Range("N1").Select
ActiveCell.FormulaR1C1 = "LIBELLE"
'Determination de la plage en colonne A
Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
'remplissage colonne J avec les formules
Selection.Offset(, 9).Select
Selection.FormulaR1C1 = "=SUMIF(SG!C3:C7,C3,SG!C6)"
'remplissage colonne K avec les formules
Selection.Offset(, 1).Select
Selection.FormulaR1C1 = "=+RC[-2]*RC[-1]"
'remplissage colonne L avec les formules
Selection.Offset(, 1).Select
Selection.FormulaR1C1 = "=ROUND(RC[-1],2)"
'remplissage colonne M avec les formules
Selection.Offset(, 1).Select
Selection.FormulaR1C1 = "=CONCATENATE(RC[-7],RC[-6])"
'remplissage colonne M avec les formules
Selection.Offset(, 1).Select
Selection.FormulaR1C1 = "=VLOOKUP(C3,SG!C3:C7,5,FALSE)"
'Collage des valeurs des colonnes J à N
'Définition de la plage concernée
Range(Selection, Selection.Offset(0, -4)).Select
'Collage des valeurs
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
    Range("J2").Select

MsgBox "durée du traitement: " & Timer - Start & " secondes"
End Sub

Avec mon PC, 2,234 s sur l'original et 0,218 avec ce code

Cordialement

h2so4

Banzai64

Amadeus,

Bonjour,

Mille merci, je ne sais pas comment vous remercier pour votre retour (aussi rapide) merci pour votre solidarité ..

Je teste vos trois propositions et reviens vers vous. (pour notamment mieux comprendre votre code et retrouver éventuellement mes erreurs de débutante !!!)

A priori Amadeus, la votre tourne mais ne s'arrête pas.

Merci encore le soleil rayonne bien plus maintenant.

Great forum

Bonjour

avec le fichier, il s'arrête (chez moi du moins)

Cordialement

Amadéus a écrit :

Bonjour

avec le fichier, il s'arrête (chez moi du moins)

Cordialement

Ok je testerai a nouveau merci Amadeus