RECHERCHEV + calcul Par Macro

[Foufoudora]

Bonjour,
Je sollicite vos lumières
comme je suis un profane dans la matière de VBA je cherche une aide pour afficher valeurs et faire differents calculs par macro car fichier trop grand >10 000 Lignes et ca rame.

voir fichier joint.
Zone Grise est saisie, Zone Orange à Calculer par VBA (Recherchev et Calcul)

Merci d'avance

Foufoudora

 

[JeanMarie]

Re : RECHERCHEV + calcul Par Macro

Bonjour Foufoudora

Tu demandes des calculs inutiles dans les gestions d'erreurs de toutes tes formules, ce qui alourdit forcément les temps de calculs. Une gestion différente des erreurs des RECHERCHEV, simplifiera d'autres formules.

Je m'explique :
° Dans la cellule X2, tu as =SI(ESTERREUR($J2*(U2));0;$J2*(U2))
ta gestion d'erreur va être à 80 % dûe à la valeur de la cellule U2, tu peux donc éviter de faire une multiplication $J2*U2 devient ESTERREUR(U2). Tu vas de me dire oui pour les 20%, peut venir d'une saisie d'une valeur texte dans la cellule J2, pour cela, il est facile de faire une gestion de saisie de la cellule J2, par le menu Données/Validation.../Choisir numérique, >= 0, et le tour est joué.
On finit par =SI(ESTERREUR(U2);0;$J2*U2)
° On pourrait arrêter cette démarche si tu n'avais qu'une cellule gérant une gestion d'erreur. Ce qui n'est pas le cas. Comme pour la gestion de la saisie de la cellule J2 à la "source", met ta gestion d'erreur dans la cellule qui retourne l'erreur, dans U2
=SI(ESTNA(RECHERCHEV(E2;Base_V!$A:$D;4;FAUX));0;RECHERCHEV(E2;Base_V!$A:$D;4;FAUX))
ce qui donne une nouvelle formule dans la cellule X2 =$J2*U2

Tu peux appliquer cette démarche à l'ensemble de tes formules.
Tu verras après que les formules seront plus simples, à transposer en VBA

Tu fais un p'tit essai de code VBA, avec les nouvelles formules allégées, et reviens avec ton nouveau classeur.

@+Jean-Marie

 

[Foufoudora]

Re : RECHERCHEV + calcul Par Macro

Bonjour Jean Marie,

J'ai appliqué tes conseils et c'est vrai ca a allégé les formules et bien sur un peu mon fichier mais il est toujours très grand et à chaque fois je saisi il met du temps pour le calcul.
C'est pour cette raison j'ai sollicité vos lumières en VBA comme ca il calcul ce qui nécessaire.
Si tu peux m'aider en Macro pour alléger mon fichier je te serai reconnaissant et bien sur quelques explications ne m'ont fait pas mal

Cordialement

foufoudora

 

[JeanMarie]

Re : RECHERCHEV + calcul Par Macro

Bonjour

P'tite question, comment veux-tu enclencher la macro ?
- Un bouton fait recalculer la feuille entière.
- Quand une modification d'une cellule intervient dans la plage de saisie, la macro ne recalcule que la ligne concernée.

Précise ce que tu veux.

@+Jean-Marie

 

[Foufoudora]

Re : RECHERCHEV + calcul Par Macro

Salut Jean Marie,

En fait après la saisie il y a un bouton qui transfert les données d'une feuille à l'autre par Macro ( ce n'est pas moi qui a fait la macro) si possible le calcul se fait en même temps de tarnsfert.

Merci d'avance

 

[JeanMarie]

Re : RECHERCHEV + calcul Par Macro

Bonsoir

Difficile de te répondre, il n'y avait aucune macro dans ton fichier joint. Comment veux-tu que je l'intègre à ton fichier.

@+Jean-Marie

 

[Foufoudora]

Re : RECHERCHEV + calcul Par Macro

salut JM,
excuses-moi mais j'ai allégé le fichier pour pouvoir le mettre sur le Forum, à la fin j'ai rajouté un code pour enregistrer les données de la feuille "traitement" dans un autre fichier fermé mais le fichier s'ouvre, j'ai essayé le code de Michel_xld mais je n'ai pas réussi si tu peux me donner des idées !!! 🙁 😕

Mille Merci


voilà le code :

Sub NewVersion()
Dim Tabresult() As Variant
Dim TabTemp As Variant
Dim TabSomme() As Variant
Dim TabTraitement As Variant 'on définit un tableau
Dim Derlgn As Integer, Derlgn2 As Integer, L As Integer, Lig_M As Integer
Dim C As Byte, x As Byte, I As Byte
Dim cel As Range, maplage As Range
Dim Date_T As Date
Dim maVar As String
Dim DerCol As Byte, Item As Byte
Dim WBSource As Workbook, WSSource As Worksheet
Dim WBCible As Workbook, WSCible As Worksheet
Dim RSource As Range, RCible As Range
Const CheminDatabase As String = "C:\Documents and Settings\Mes documents\Suivi.xls"
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ReDim TabSomme(1, 6)
With Worksheets("Saisie")
'.Unprotect 'on déprotège
Derlgn = .Range("B65536").End(xlUp).Row 'B car il y a des formules dans la colonne A
If Derlgn = 3 Then Derlgn = 4
TabTemp = .Range(.Cells(4, 1), .Cells(Derlgn, 20)).Value 'ici le 20 représente la derniere colonne prise en compte
'.Protect 'on reprotége
End With
With Worksheets("Traitement")
.Unprotect 'on déprotège
Derlgn2 = .Range("A65536").End(xlUp).Row 'détecte la derniere ligne non vide
For L = 1 To UBound(TabTemp, 1) 'pour chaque ligne du tableau
If TabTemp(1, 1) = "" Then Exit Sub 'On sort si pas de données
If Year(TabTemp(1, 1)) <> Worksheets("Archives").Range("A1") Then GoTo suite
Date_T = CDate(TabTemp(1, 1))
ReDim TabSomme(1, 6)
For C = 1 To UBound(TabTemp, 2) 'pour chaque Colonne du tableau
.Cells(Derlgn2 + L, C) = TabTemp(L, C) 'ici on colle les données
Next
.Calculate
Next
suite:
Derlgn2 = .Range("A65536").End(xlUp).Row 'détecte la derniere ligne vide
'puis l'on tri la plage définie en fonction des dates
.Range("A1:AY" & Derlgn2).Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

.Protect 'on reprotége

Dim TabArchives() As Variant 'on définit un tableau
Dim Col_Date As Collection 'on définit une collection
Set Col_Date = New Collection
'IJKLMNSVXZ

Derlgn2 = .Range("A65536").End(xlUp).Row 'détecte la derniere ligne non vide
DerCol = .Range("IV1").End(xlToLeft).Column ''détecte la derniere Colonne non vide
TabTraitement = .Range(.Cells(2, 1), .Cells(Derlgn2, DerCol)).Value 'on remplit le tableau

For L = 1 To UBound(TabTraitement, 1) 'on va créer une collection des dates(Uniques)
On Error Resume Next
Col_Date.Add DateSerial(Year(CDate(TabTraitement(L, 1))), Month(CDate(TabTraitement(L, 1))), 1), CStr(DateSerial(Year(CDate(TabTraitement(L, 1))), Month(CDate(TabTraitement(L, 1))), 1))
On Error GoTo 0
Err.Clear
Next

For Item = 1 To Col_Date.Count 'pour chaque dates

ReDim Preserve TabArchives(8, x) 'on redimensionne un tableau 8 colonnes

For L = 1 To UBound(TabTraitement, 1) 'puis pour chaque ligne
TabArchives(0, x) = CDate(Col_Date(Item)) 'Format(CDate(Col_Date(Item)), "dd/mm/yyyy") 'ici on colle la date

If Month(CDate(TabTraitement(L, 1))) = Month(CDate(Col_Date(Item))) Then 'si date de la Colonne 1 est égale à celle de la collection
TabArchives(1, x) = TabArchives(1, x) + TabTraitement(L, 10) 'On colle Qté Prod PF
TabArchives(2, x) = TabArchives(2, x) + TabTraitement(L, 11) 'etc
TabArchives(3, x) = TabArchives(3, x) + TabTraitement(L, 12)
TabArchives(4, x) = TabArchives(4, x) + TabTraitement(L, 16)
TabArchives(5, x) = TabArchives(5, x) + TabTraitement(L, 27)
TabArchives(6, x) = TabArchives(6, x) + TabTraitement(L, 34)
TabArchives(7, x) = TabArchives(7, x) + TabTraitement(L, 42)
TabArchives(8, x) = TabArchives(8, x) + TabTraitement(L, 50)

End If
Next
x = x + 1
Next

End With
With Worksheets("Archives")
Application.EnableEvents = False
.Unprotect
.Range("B2:I14").ClearContents

Set maplage = .Range("A1:A14") 'définit la variable maplage
For C = 0 To UBound(TabArchives, 2) 'pour chaque colonne
maVar = Format(DateSerial(Year(CDate(TabArchives(0, C))), Month(CDate(TabArchives(0, C))), 1), "mmm-yy") 'on formate la date
With maplage
Set cel = .Find(maVar, LookIn:=xlValues) 'définit la variable Cel (recherche maVar dans la plage)
End With

If Not cel Is Nothing Then 'si il existe au moins une occurrence
Lig_M = cel.Row 'ici on récupère le numero de la ligne
For L = 1 To 8
.Cells(Lig_M, 1 + L) = .Cells(Lig_M, 1 + L) + CDbl(TabArchives(L, C)) 'on colle le tableau sur la ligne
Next

End If
Next
Application.EnableEvents = True

.Calculate 'on lance le calcul de la feuille
.Protect
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

' code pour enregistrer dans un autre fichier
Set WBSource = ThisWorkbook
Set WSSource = WBSource.Sheets("traitement")
Set RSource = WSSource.Range("A2:T6000")

Set WBCible = Workbooks.Open(CheminDatabase)
Set WSCible = WBCible.Sheets("Analyse")

Set RCible = WSCible.Range("A65536").End(xlUp)(2)

RSource.Copy RCible
WBCible.Close True





End Sub