[VBA] Préservation formules existantes (+identification adresse cellules)

Staple1600 · 15 Février 2018

Bonsoir le fil, le forum

Dans un classeur identique à ce que donne la macro datas, je cherche à créer une macro qui pourra réinjecter toutes formules (qui sont toutes en relation avec les valeurs en colonne A)

Voir ce petit exemple (avec deux formules)

VB:

Sub insert_formules()
'////////////////////////////////////////
datas 'macro juste pour créer données de test
'///////////////////////////////////////
'macro pour insérer formules
Dim i As Byte, adr
adr = Array(1, 5, 10)
For i = 0 To UBound(adr)
Cells(adr(i), "D").FormulaArray = "=MIN(IF(R1C1:R15C1=RC1,R1C2:R15C2))"
'avec la formule ci-dessous
'comment recopier jusqu'à la dernière cellule avant le changement de valeur en colonne A
Cells(adr(i), "F").FormulaR1C1 = "=RC[-4]/R" & adr(i) & "C4"
'ce genre de problème d'identification de la dernière cellule à mettre dans les formules 
'se reproduira pour N formules présentes dans le classeur
Next
End Sub
Private Sub datas()
Cells.Clear
[A1] = 1: [A5] = 2: [A10] = 3: [B1] = 100: [B2] = 97
 With Range("A1:A15")
    .SpecialCells(xlCellTypeBlanks).Formula = "=A1"
    .Value = .Value
End With
[B1:B2].AutoFill Destination:=Range("B1:B15")
End Sub

Je cherche le meilleur moyen d'identifier le changement de valeur en colonne A pour pouvoir en seule macro "remettre" les formules initiales (qui seront donc en dur dans le code)

Le but c'est d'éviter au maximum les suppressions accidentelles de formules (la personne utilisant le classeur ne maîtrisant pas Excel)

job75 · 17 Février 2018

Re,

J'ai un peu modifié la macro pour la rendre plus générale :

Code:

Sub ReconstruireFormules()
Dim ColA As Range, i&, n&, zoneA&(), celBaseF1, plageF1 As Range, plageF2 As Range, plageF3 As Range
Dim pas%, plageMoy$, deb&, fin&
Application.ScreenUpdating = False
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData 'si la feuille est filtrée
Set ColA = Range("A3", Range("A" & Rows.Count).End(xlUp))
If ColA.Row < 3 Then Exit Sub 'si tableau vide
ColA.EntireRow.Sort ColA, xlAscending, Header:=xlNo 'tri de sécurité
On Error Resume Next 'si aucune SpecialCell
ColA.SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'vides
ColA.SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete 'textes
If ColA.Count = 0 Then Exit Sub
On Error GoTo 0
'---mémorisation des lignes de début et de fin de zones en colonne A---
For i = 1 To ColA.Count
    If ColA(i) <> ColA(i - 1) Then
        n = n + 1
        ReDim Preserve zoneA(1 To 2, 1 To n)
        zoneA(1, n) = i
    End If
    zoneA(2, n) = i
Next
'---initialisation des cellules de base et des plages des formules, à adapter éventuellement---
celBaseF1 = Array("H3", "J3", "L3", "N3", "P3") 'adresses (sans signe $)
Set plageF1 = Intersect(ColA.EntireRow, [T:T])
Set plageF2 = Intersect(ColA.EntireRow, [U:U])
Set plageF3 = Intersect(ColA.EntireRow, [V:V])
pas = 5 'décalage vers la droite
'---formules F1 F2 F3---
For i = 0 To UBound(celBaseF1)
    Set plageF1 = plageF1.Offset(, pas * Sgn(i))
    Set plageF2 = plageF2.Offset(, pas * Sgn(i)): plageF2 = ""
    Set plageF3 = plageF3.Offset(, pas * Sgn(i))
    plageMoy = plageMoy & "," & plageF3(1).Address(0, 0) 'concaténation des adresses
    plageF1 = "=" & celBaseF1(i) & "*" & plageF1(1, -1).Address(0, 0) & "+2*" & plageF1(1, 0).Address(0, 0)
    For n = 1 To UBound(zoneA, 2)
        deb = zoneA(1, n): fin = zoneA(2, n)
        plageF2(deb) = "=MIN(" & plageF1(deb).Address(0, 0) & ":" & plageF1(fin).Address(0, 0) & ")"
        plageF3(deb).Resize(fin - deb + 1) = "=13*" & plageF2(deb).Address(1, 0) & "/" & plageF1(deb).Address(0, 0)
Next n, i
'---dernières formules---
plageF3.Offset(, 1) = "=AVERAGE(" & Mid(plageMoy, 2) & ")"
plageF3.Offset(, 6) = "=SUM(" & plageF3(1, 2).Resize(, 5).Address(0, 0) & ")"
End Sub

A+

Staple1600 · 17 Février 2018

Bonjour job75

Merci pour cette nouvelle version.
(que je testerai lundi au boulot)

NB: Je suppose que l'idée de mon précédent message est à oublier
Comme tu ne l'as pas commentée.

job75 · 17 Février 2018

Re,

Bah le test sur ActiveSheetFilterMode doit être placé avant le End(xlUp)...

A+

Staple1600 · 17 Février 2018

Re

@job75
On s'est pas mal compris

Je voulais parlais de l'idée de placer toutes les formules d'une feuille active dans un Array
pour ensuite les restituer
(voir message#30)

Je voulais dire comme tu n'as pas émis de commentaire dessus,
je suppose par conséquent c'est une idée à oublier, non ?

job75 · 17 Février 2018

Staple1600 à dit:
Je voulais dire comme tu n'as pas émis de commentaire dessus,
je suppose par conséquent c'est une idée à oublier, non ?

Oui c'est sans intérêt ici.

Et je ne passe pas mon temps à répondre à tous les messages, je fais plein d'autres choses par ailleurs.

Staple1600 · 17 Février 2018

Re

@job75
Merci d'avoir éclairer ma lanterne.

NB: Il ne s'agissait pas de répondre à tous les messages (aucun xldnaute ne le fait)
J’émettais juste une hypothèse dans mon fil en espérant que toi ou ceux qui s’y intéressent infirme ou développe cette piste.

Même si ici cette piste (formules dans un Array) n'est pas utile, je cherche toujours (pour ma gouverne) comment restituer le contenu de l'Array sans passer par la dernière boucle.

Merci à ceux qui m'indiqueront comme faire (ou pas)

eriiic · 17 Février 2018

Re,

j'ai du mal à imaginer comment le faire sans boucle.
Mais quitte à enregistrer les formules quelque part je le ferais dans une feuille masquée plutôt qu'en dur dans la macro. Ca simplifierait considérablement le code, et une éventuelle évolution.
eric

Staple1600 · 17 Février 2018

Bonsoir eriiiic

Merci de ta réponse
J'avais aussi pensé à dupliquer la feuille originale puis à la masquer
Mais si jamais la feuille est modifiée (ajout de ligne ou de colonne) et que je réinjecte les formules à partir de la feuille masquée, ce sera le souk, non.?

Pour le moment je vais tester avec la macro de job75 et voir aussi ce que cela donne à l'usage en protégeant la feuille sur le PC de l'utilisateur final.

Sinon pour mon histoire d'Array, je voulais tenter un truc du genre

VB:

Sub a()' test OK
Dim t
Range("A1:B5") = "=ROW()*COLUMN()"
Range("C1:C5") = "=ROW()*COLUMN()^2"
t = Range("A1:C5").Formula
Cells.Clear
Range("A1:C5") = t
End Sub

Mais comme ceci cela ne fonctionne évidemment pas

VB:

Sub test_Arrays_Formules_pasOK()
Dim x&, i&, t(), c As Range
Cells.Clear
[A1] = "=TODAY()": [C3] = "=ROW()": [E5] = "=COLUMN()": [H7] = "=PI()"
x = ActiveSheet.UsedRange.SpecialCells(-4123, 23).Count
adrss = ActiveSheet.UsedRange.SpecialCells(-4123, 23).Address
ReDim t(1 To x): i = 1
For Each c In ActiveSheet.UsedRange.SpecialCells(-4123, 23)
t(i) = c.Formula
i = i + 1
Next
Cells.Clear
MsgBox t(3) 'pour test
Range(adrss) = t
End Sub

job75 · 18 Février 2018

Bonjour JM, le forum,

Voici une solution beaucoup plus rapide car elle utilise 2 tableaux VBA auxiliaires a et b :

Code:

Sub ReconstruireFormulesRapidement()
Dim ColA As Range, i&, n&, zoneA&(), celBaseF1, plageF1 As Range, plageF2 As Range, plageF3 As Range
Dim pas%, a(), b(), plageMoy$, deb&, fin&, f$
Application.ScreenUpdating = False
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData 'si la feuille est filtrée
Set ColA = Range("A3", Range("A" & Rows.Count).End(xlUp))
If ColA.Row < 3 Then Exit Sub 'si tableau vide
ColA.EntireRow.Sort ColA, xlAscending, Header:=xlNo 'tri de sécurité
On Error Resume Next 'si aucune SpecialCell
ColA.SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'vides
ColA.SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete 'textes
If ColA.Count = 0 Then Exit Sub
On Error GoTo 0
Application.Calculation = xlCalculationManual
'---mémorisation des lignes de début et de fin de zones en colonne A---
For i = 1 To ColA.Count
    If ColA(i) <> ColA(i - 1) Then
        n = n + 1
        ReDim Preserve zoneA(1 To 2, 1 To n)
        zoneA(1, n) = i
    End If
    zoneA(2, n) = i
Next i
'---initialisation des cellules de base et des plages des formules, à adapter éventuellement---
celBaseF1 = Array("H3", "J3", "L3", "N3", "P3") 'adresses (sans signe $)
Set plageF1 = Intersect(ColA.EntireRow, [T:T])
Set plageF2 = Intersect(ColA.EntireRow, [U:U])
Set plageF3 = Intersect(ColA.EntireRow, [V:V])
pas = 5 'décalage vers la droite
'---formules F1 F2 F3---
ReDim a(1 To ColA.Count, 1 To 1): b = a '2 tableaux auxiliaires pour accélérer
For i = 0 To UBound(celBaseF1)
    Set plageF1 = plageF1.Offset(, pas * Sgn(i))
    Set plageF2 = plageF2.Offset(, pas * Sgn(i))
    Set plageF3 = plageF3.Offset(, pas * Sgn(i))
    plageMoy = plageMoy & "," & plageF3(1).Address(0, 0) 'concaténation des adresses
    plageF1 = "=" & celBaseF1(i) & "*" & plageF1(1, -1).Address(0, 0) & "+2*" & plageF1(1, 0).Address(0, 0)
    For n = 1 To UBound(zoneA, 2)
        deb = zoneA(1, n): fin = zoneA(2, n)
        a(deb, 1) = "=MIN(" & plageF1(deb).Address(0, 0) & ":" & plageF1(fin).Address(0, 0) & ")"
        f = "=13*" & plageF2(deb).Address(1, 0, ReferenceStyle:=xlR1C1, RelativeTo:=plageF3(deb)) _
            & "/" & plageF1(deb).Address(0, 0, ReferenceStyle:=xlR1C1, RelativeTo:=plageF3(deb))
        For deb = deb To fin
            b(deb, 1) = f
    Next deb, n
    plageF2 = a: plageF3 = b 'restitution
Next i
'---dernières formules---
plageF3.Offset(, 1) = "=AVERAGE(" & Mid(plageMoy, 2) & ")"
plageF3.Offset(, 6) = "=SUM(" & plageF3(1, 2).Resize(, 5).Address(0, 0) & ")"
Application.Calculation = xlCalculationAutomatic
End Sub

Sur 26 lignes elle s'exécute chez moi en 0,009 seconde au lieu de 0,15 seconde précédemment.

Elle est donc 16 fois plus rapide, ce sera bien utile sur un grand tableau.

PS : bien comprendre JM que ce sont les boucles imbriquées qui prennent du temps, il faut alors les traiter par des tableaux.

Bonne journée.

Staple1600 · 18 Février 2018

Bonjour le fil, le forum, job75

@job75
Merci pour cette nouvelle version.
Je te dirai lundi soir ce que cela donne sur le tableau original.

Sinon concernant ton code, je cherche à comprendre cette syntaxe
Set plageF1 = plageF1.Offset(, pas * Sgn(i))
Pourquoi l'emploi de Sgn?
Sgn(0) renvoie 0 ensuite i >0 donc Sgn(i) renvoie 1
Donc pour i=0 on aura plageF1.Offset(, 0), ce qui permet de ne pas décaler pour le 1er élément, c'est ça?
NB: Je crois avoir compris tout en rédigeant le message et avec la petite macro de test ci-dessous

VB:

Sub testSgn()
Dim ColA As Range, i&, n&, zoneA&(), celBaseF1, plageF1 As Range, plageF2 As Range, plageF3 As Range
Dim pas%, a(), b(), plageMoy$, deb&, fin&, f$
Dim test$
Set ColA = Range("A3", Range("A" & Rows.Count).End(xlUp))
celBaseF1 = Array("H3", "J3", "L3", "N3", "P3") 'adresses (sans signe $)
Set plageF1 = Intersect(ColA.EntireRow, [T:T])
Set plageF2 = Intersect(ColA.EntireRow, [U:U])
Set plageF3 = Intersect(ColA.EntireRow, [V:V])
pas = 5 'décalage vers la droite
'---formules F1 F2 F3---
ReDim a(1 To ColA.Count, 1 To 1): b = a '2 tableaux auxiliaires pour accélérer
For i = 0 To UBound(celBaseF1)
    Set plageF1 = plageF1.Offset(, pas * Sgn(i))
    test = test & "(valeur de i:" & i & "), " & Chr(13) & plageF1.Address & Chr(13)
    Set plageF2 = plageF2.Offset(, pas * Sgn(i))
    test = test & plageF2.Address & Chr(13)
    Set plageF3 = plageF3.Offset(, pas * Sgn(i))
    test = test & plageF3.Address & Chr(13)
Next i
Debug.Print test
End Sub

job75 · 18 Février 2018

Re,

Au post #39 j'ai ajouté les Application.Calculation cela fait gagner encore un peu de temps.

Sur un tableau de 26 000 lignes (4000 zones en colonne A) la durée d'exécution est de 6,0 secondes.

A+

Staple1600 · 18 Février 2018

Re

@job75
• De mémoire, le tableau doit faire moins de 500 lignes.

• Le nombre de zones ne devrait pas dépasser 30
Actuellement (et toujours de mémoire) il est de 16.

job75 · 19 Février 2018

Bonjour JM, le forum,

Avec un si petit fichier ma dernière macro s'exécutera en moins de 1/10ème de seconde.

Il est alors plus simple de placer dans le code de la feuille :

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A:A,T:V,Y:AA,AD:AF,AI:AK,AN:AQ,AV:AV]) Is Nothing Then Exit Sub 'à adapter
Dim i&, ColA As Range, n&, zoneA&(), celBaseF1, plageF1 As Range, plageF2 As Range, plageF3 As Range
Dim pas%, a(), b(), plageMoy$, deb&, fin&, f$
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
On Error Resume Next 'si aucune SpecialCell
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData 'si la feuille est filtrée
i = Range("A" & Rows.Count).End(xlUp).Row
Rows(IIf(i < 3, 3, i + 1) & ":" & Rows.Count).Delete 'RAZ en dessous
If i < 3 Then GoTo 1
'---détermination de ColA et épuration---
Set ColA = Range("A3.A" & i)
ColA.EntireRow.Sort ColA, xlAscending, Header:=xlNo 'tri de sécurité
ColA.SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'vides
ColA.SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete 'textes
If ColA.Count = 0 Then GoTo 1
'---mémorisation des lignes de début et de fin de zones en colonne A---
For i = 1 To ColA.Count
    If ColA(i) <> ColA(i - 1) Then
        n = n + 1
        ReDim Preserve zoneA(1 To 2, 1 To n)
        zoneA(1, n) = i
    End If
    zoneA(2, n) = i
Next i
'---initialisation des cellules de base et des plages des formules, à adapter éventuellement---
celBaseF1 = Array("H3", "J3", "L3", "N3", "P3") 'adresses (sans signe $)
Set plageF1 = Intersect(ColA.EntireRow, [T:T])
Set plageF2 = Intersect(ColA.EntireRow, [U:U])
Set plageF3 = Intersect(ColA.EntireRow, [V:V])
pas = 5 'décalage vers la droite
'---formules F1 F2 F3---
ReDim a(1 To ColA.Count, 1 To 1): b = a '2 tableaux auxiliaires pour accélérer
For i = 0 To UBound(celBaseF1)
    Set plageF1 = plageF1.Offset(, pas * Sgn(i))
    Set plageF2 = plageF2.Offset(, pas * Sgn(i))
    Set plageF3 = plageF3.Offset(, pas * Sgn(i))
    plageMoy = plageMoy & "," & plageF3(1).Address(0, 0) 'concaténation des adresses
    plageF1 = "=" & celBaseF1(i) & "*" & plageF1(1, -1).Address(0, 0) & "+2*" & plageF1(1, 0).Address(0, 0)
    For n = 1 To UBound(zoneA, 2)
        deb = zoneA(1, n): fin = zoneA(2, n)
        a(deb, 1) = "=MIN(" & plageF1(deb).Address(0, 0) & ":" & plageF1(fin).Address(0, 0) & ")"
        f = "=13*" & plageF2(deb).Address(1, 0, ReferenceStyle:=xlR1C1, RelativeTo:=plageF3(deb)) _
            & "/" & plageF1(deb).Address(0, 0, ReferenceStyle:=xlR1C1, RelativeTo:=plageF3(deb))
        For deb = deb To fin
            b(deb, 1) = f
    Next deb, n
    plageF2 = a: plageF3 = b 'restitution
Next i
'---dernières formules---
plageF3.Offset(, 1) = "=AVERAGE(" & Mid(plageMoy, 2) & ")"
plageF3.Offset(, 6) = "=SUM(" & plageF3(1, 2).Resize(, 5).Address(0, 0) & ")"
1 Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub

La macro s'exécute chaque fois que l'utilisateur modifie la colonne A ou des formules.

A+

job75 · 19 Février 2018

Re,

Si l'utilisateur trie le tableau sur une autre colonne que A les formules des minima ne sont plus correctes.

Pour corriger le tri il suffit d'ajouter cette macro :

Code:

Private Sub Worksheet_Calculate()
Dim i As Variant
i = Application.Match(9 ^ 99, [A:A])
'---correction si le tableau est trié sur une autre colonne que la colonne A---
If Val(CStr(i)) > 4 Then If Evaluate("SUM(-(A3:A" & i - 1 & "<A4:A" & i & "))") _
    And Evaluate("SUM(-(A3:A" & i - 1 & ">A4:A" & i & "))") Or [U3] = "" _
        Then Worksheet_Change [A3]: Application.ScreenUpdating = True
End Sub

A+

Staple1600 · 19 Février 2018

Bonsoir le fil, le forum, job75

@job75
Test OK de ton code sur le fichier original.

Après le tableau où restituer les formules, il y a des données (sans formules pour le moment) : commentaires, notes observations etc...

Donc, je vais voir comment faire pour circonscrire le code au seul tableau avec formules.

PS:je teste demain ta procédure événementielle.

Merci encore pour ce code VBA.

[VBA] Préservation formules existantes (+identification adresse cellules)

Staple1600

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

eriiic

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

Discussions similaires